home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / os2 / forth038.arj / FORTH.ASM < prev    next >
Assembly Source File  |  1994-01-20  |  109KB  |  3,832 lines
  1.            Title   _FORTH_32 '32 BIT FORTH FOR OS/2'
  2. ;
  3. ; FORTH/2 -- Copyright(C) 1992-1994 BLUE STAR SYSTEMS, all rights reserved
  4. ; Produced in the United States of America
  5. ;
  6. ;   This software is furnished under a license agreement or nondisclosure
  7. ; agreement.  The software may be used or copied only in accordance with
  8. ; the terms of the agreement. No part of this program may be reproduced
  9. ; or transmitted in any form or by any means, electronic or mechanical,
  10. ; including photo-copying and recording, for any purpose without the
  11. ; express written permission of the author.
  12. ;
  13. ;   The following paragraph does not apply in the United Kingdom or any
  14. ; country where such provisions are inconsistent with local law:
  15. ;   BLUE STAR SYSTEMS OFFERS THIS PROGRAM "AS IS" WITHOUT WARRANTY OF
  16. ; ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
  17. ; IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
  18. ; Some states do not allow disclaimer of express or implied warranties in
  19. ; certain transactions, therefore, this statement may not apply to you.
  20. ;
  21. ; BLUE STAR SYSTEMS may have patents or pending patent applications covering
  22. ; the subject matter in this program. The furnishing of this program does
  23. ; not give you any license to these patents. You can send license inquiries,
  24. ; to any of the following:
  25. ;
  26. ;   US Mail: BLUE STAR SYSTEMS
  27. ;            1350 BirchCrest Blvd
  28. ;            Port Charlotte, Florida 33952
  29. ;
  30. ;   Email:   ka9dgx@chinet.com
  31. ;
  32. ;   Voice:   (813) 629-9313
  33. ;
  34. ; Note: 16 Bit calls EAT STACK PARAMS
  35. ;       32 Bit calls LEAVE stack params
  36. ;
  37. ; Thanks to Larry Bank for his sample code in VIO32.ASM
  38. ; Thanks to Brian Mathewson for his $$$ and suggestions, and CODE
  39. ; Thanks to Michael Thompson (tommy@msc.cornell.edu) for PORTIO.ASM
  40. ;
  41.           .386
  42.           .model   flat,syscall,os_os2
  43.  
  44.           .code
  45.  
  46. Reserve_Size   =       010000h ; Reserve 64k Of Memory for Dictionary
  47.  
  48. STACK_SIZE       = 1000h   ; Memory reserved for stack
  49. STACK_UNDERFLOW  = 1000h
  50. RSTACK_SIZE      = 1000h   ; Return stack size for threads
  51.  
  52.            EXTRN   Dos32AllocMem:Near,Dos32Read:Near
  53.            EXTRN   Dos32Beep:Near,Dos32SetFilePtr:Near
  54.            EXTRN   Dos32CallNPipe:Near,Dos32ConnectNPipe:Near
  55.            EXTRN   Dos32CreateNPipe:Near
  56.            EXTRN   Dos32CreateThread:Near
  57.            EXTRN   Dos32DevIOCtl:Near
  58.            EXTRN   Dos32DisConnectNPipe:Near
  59.            EXTRN   Dos32ExecPgm:Near
  60.            EXTRN   Dos32Exit:Near
  61.            EXTRN   Dos32GetDateTime:Near
  62.                EXTRN   Dos32GetInfoBlocks:Near
  63.            EXTRN   Dos32KillProcess:Near
  64.            EXTRN   Dos32KillThread:Near
  65.            EXTRN   Dos32LoadModule:Near,Dos32FreeModule:Near
  66.            EXTRN   Dos32Open:Near,Dos32Close:Near
  67.            EXTRN   Dos32PeekNPipe:Near
  68.            EXTRN   Dos32QueryModuleHandle:Near
  69.            EXTRN   Dos32QueryModuleName:Near
  70.            EXTRN   Dos32QueryNPHState:Near,Dos32QueryNPipeInfo:Near
  71.            EXTRN   Dos32QueryProcAddr:Near
  72.            EXTRN   Dos32QueryProcType:Near
  73.            EXTRN   Dos32ResumeThread:Near
  74.            EXTRN   Dos32SetNPHState:Near
  75.            EXTRN   Dos32Sleep:Near,Dos32StartSession:Near
  76.            EXTRN   Dos32SuspendThread:Near
  77.            EXTRN   Dos32TransactNPipe:Near
  78.            EXTRN   Dos32WaitChild:Near
  79.            EXTRN   Dos32WaitNPipe:Near
  80.            EXTRN   Dos32WaitThread:Near
  81.            EXTRN   Dos32Write:Near
  82.  
  83.  
  84.            EXTRN   DosFlatToSel:near,DosSelToFlat:near
  85.            EXTRN   KbdCharIn:far16,VIOwrtTTY:far16
  86.            EXTRN   Dos32Shutdown:Near
  87.  
  88.            EXTRN   @inp:far16,@outp:far16
  89.  
  90. PULLFORTH      MACRO
  91.            mov     eax,[ebx]
  92.            add     ebx,4
  93.            ENDM
  94.  
  95. PUSHFORTH      MACRO
  96.            sub     ebx,4
  97.            mov     [ebx],eax
  98.            ENDM
  99.  
  100. COMPILES       MACRO   varg:VARARG
  101.          FOR     arg, <varg>
  102.            mov     al,arg
  103.            stosb
  104.          ENDM
  105.            ENDM
  106.  
  107. UREG           EQU  EBP                 ; USER Variable register
  108. UserAreaSize   EQU  400h                ; Size of user variable area
  109. USER           EQU  -U_UserVPtr [UREG]  ; USER variable
  110. ; USER         EQU                      ; Use to disable USER variables
  111.  
  112. VocLinkOffset  =       4        ; Offset from vocabulary of link
  113. ContextSize    =       16       ; Size of Context buffer
  114.  
  115.           .stack   8192
  116.           .data
  117.  
  118. ;
  119. ; Data returned from getkey...
  120. ;
  121. ascii         db     0
  122. scancode      db     0
  123. status        db     0
  124. reserved      db     0
  125. shift_state   dw     0
  126. time_stamp    dd     0
  127. ;
  128.  
  129. ;---------------- I/O DOS Calls Only---------------
  130. stdin          equ   0
  131. stdout         equ   1
  132. stderr         equ   2
  133.  
  134. ;---------------- Useful ---------------
  135. cr             equ   0dh
  136. lf             equ   0ah
  137. crlf           equ   0dh,0ah   ;cr+lf
  138. BEL            equ   07h
  139. NULL           equ   0000h
  140.  
  141. SavedESP       dd    ?
  142.  
  143. Environment    dd    ?
  144. CommandLine    dd    ?
  145. FooBar         dd    ?
  146.  
  147.  
  148. ;********* Forth REGISTER USE:
  149. ;
  150. ;  EBX - Numeric Stack pointer, growing downward from FStackBase
  151. ;
  152. ;  EDI - Current CODE generating address
  153. ;
  154. ;  EBP - Pointer to USER variable block ( one block per thread! )
  155. ;
  156. ;  All other variables my be used, and trashed, at ANY time....!
  157. ;
  158.  
  159. Message        MACRO  name:REQ,string:VARARG
  160.  
  161. &name&msg      dd     @f-($+4)  ;; define a DWORD which gives size
  162.  
  163.            FOR arg, <string>
  164.          DB    arg             ;; Store the byte(s)
  165.            ENDM
  166. @@:
  167. ENDM
  168.  
  169.  
  170. MESSAGE Welcome,   "FORTH/2 -- Version 0.38 ßeta"
  171.  
  172. MESSAGE CopyRight, "Copyright(C) 1992-1994 - BLUE STAR SYSTEMS, all rights reserved",CrLf,"Produced in the United States of America",CrLf,CrLf
  173.  
  174. MESSAGE Greet,     "Type BYE to exit, WORDS to see word list.",CrLf
  175.  
  176. MESSAGE Break,     "Breakpoint Encountered! ",CrLf
  177.  
  178. MESSAGE StackOver, "Stack Overflow!",07h,CrLf
  179.  
  180. MESSAGE StackUnder,"Stack Underflow!",07h,CrLf
  181.  
  182. MESSAGE IOerror,   "I/O Error #"
  183.  
  184. MESSAGE StackLoad, "FORTH.INI should not change the stack",CrLf
  185.  
  186. MESSAGE Prompt,    "Ok: "
  187.  
  188. MESSAGE CompileOnly "Not in compile mode!",CrLf
  189.  
  190. MESSAGE Semicolon  "ERROR: Semicolon was expected",CrLf
  191.  
  192. MESSAGE LineNum    "at line number: "
  193.  
  194. MESSAGE WHAT1      "What does ",022h
  195. MESSAGE WHAT2      022h," mean? (type BYE to exit to OS/2) ",CrLf
  196.  
  197. MESSAGE DivByZero  "DIVISION BY ZERO ATTEMPTED!",CrLf
  198.  
  199. MESSAGE NotCompiling "Only in compile mode!",CrLf
  200.  
  201. MESSAGE Huh        " ?",CrLf
  202.  
  203. MESSAGE NotCreateWord "not a CREATE'd word!",CrLf
  204.  
  205. MESSAGE Register   "   EDI      ESI      EBP      ESP      EBX      EDX      ECX      EAX",CrLf
  206.  
  207. MESSAGE Pause      "--PRESS ANY KEY--",Cr
  208.  
  209. MESSAGE PauseClear "                 ",Cr
  210.  
  211. CrLfStr        dd     2
  212.            db     0dh,0ah
  213.  
  214. CrStr          dd     1
  215.            db     0dh
  216.  
  217. SpStr          dd     1
  218.            db     20h
  219.  
  220. UpperCaseTable db     000h,001h,002h,003h,004h,005h,006h,007h
  221.            db     008h,009h,00ah,00bh,00ch,00dh,00eh,00fh
  222.            db     010h,011h,012h,013h,014h,015h,016h,017h
  223.            db     018h,019h,01ah,01bh,01ch,01dh,01eh,01fh
  224.            db     020h,021h,022h,023h,024h,025h,026h,027h
  225.            db     028h,029h,02ah,02bh,02ch,02dh,02eh,02fh
  226.            db     030h,031h,032h,033h,034h,035h,036h,037h
  227.            db     038h,039h,03ah,03bh,03ch,03dh,03eh,03fh
  228.            db     040h,041h,042h,043h,044h,045h,046h,047h
  229.            db     048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
  230.            db     050h,051h,052h,053h,054h,055h,056h,057h
  231.            db     058h,059h,05ah,05bh,05ch,05dh,05eh,05fh
  232.            db     060h,041h,042h,043h,044h,045h,046h,047h
  233.            db     048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
  234.            db     050h,051h,052h,053h,054h,055h,056h,057h
  235.            db     058h,059h,05ah,07bh,07ch,07dh,07eh,07fh
  236.            db     080h,081h,082h,083h,084h,085h,086h,087h
  237.            db     088h,089h,08ah,08bh,08ch,08dh,08eh,08fh
  238.            db     090h,091h,092h,093h,094h,095h,096h,097h
  239.            db     098h,099h,09ah,09bh,09ch,09dh,09eh,09fh
  240.            db     0a0h,0a1h,0a2h,0a3h,0a4h,0a5h,0a6h,0a7h
  241.            db     0a8h,0a9h,0aah,0abh,0ach,0adh,0aeh,0afh
  242.            db     0b0h,0b1h,0b2h,0b3h,0b4h,0b5h,0b6h,0b7h
  243.            db     0b8h,0b9h,0bah,0bbh,0bch,0bdh,0beh,0bfh
  244.            db     0c0h,0c1h,0c2h,0c3h,0c4h,0c5h,0c6h,0c7h
  245.            db     0c8h,0c9h,0cah,0cbh,0cch,0cdh,0ceh,0cfh
  246.            db     0d0h,0d1h,0d2h,0d3h,0d4h,0d5h,0d6h,0d7h
  247.            db     0d8h,0d9h,0dah,0dbh,0dch,0ddh,0deh,0dfh
  248.            db     0e0h,0e1h,0e2h,0e3h,0e4h,0e5h,0e6h,0e7h
  249.            db     0e8h,0e9h,0eah,0ebh,0ech,0edh,0eeh,0efh
  250.            db     0f0h,0f1h,0f2h,0f3h,0f4h,0f5h,0f6h,0f7h
  251.            db     0f8h,0f9h,0fah,0fbh,0fch,0fdh,0feh,0ffh
  252.  
  253. WordScanTable  db     020h,020h,020h,020h,020h,020h,020h,020h
  254.            db     020h,020h,020h,020h,020h,020h,020h,020h
  255.            db     020h,020h,020h,020h,020h,020h,020h,020h
  256.            db     020h,020h,020h,020h,020h,020h,020h,020h
  257.            db     020h,021h,022h,023h,024h,025h,026h,027h
  258.            db     028h,029h,02ah,02bh,02ch,02dh,02eh,02fh
  259.            db     030h,031h,032h,033h,034h,035h,036h,037h
  260.            db     038h,039h,03ah,03bh,03ch,03dh,03eh,03fh
  261.            db     040h,041h,042h,043h,044h,045h,046h,047h
  262.            db     048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
  263.            db     050h,051h,052h,053h,054h,055h,056h,057h
  264.            db     058h,059h,05ah,05bh,05ch,05dh,05eh,05fh
  265.            db     060h,061h,062h,063h,064h,065h,066h,067h
  266.            db     068h,069h,06ah,06bh,06ch,06dh,06eh,06fh
  267.            db     070h,071h,072h,073h,074h,075h,076h,077h
  268.            db     078h,079h,07ah,07bh,07ch,07dh,07eh,07fh
  269.            db     080h,081h,082h,083h,084h,085h,086h,087h
  270.            db     088h,089h,08ah,08bh,08ch,08dh,08eh,08fh
  271.            db     090h,091h,092h,093h,094h,095h,096h,097h
  272.            db     098h,099h,09ah,09bh,09ch,09dh,09eh,09fh
  273.            db     0a0h,0a1h,0a2h,0a3h,0a4h,0a5h,0a6h,0a7h
  274.            db     0a8h,0a9h,0aah,0abh,0ach,0adh,0aeh,0afh
  275.            db     0b0h,0b1h,0b2h,0b3h,0b4h,0b5h,0b6h,0b7h
  276.            db     0b8h,0b9h,0bah,0bbh,0bch,0bdh,0beh,0bfh
  277.            db     0c0h,0c1h,0c2h,0c3h,0c4h,0c5h,0c6h,0c7h
  278.            db     0c8h,0c9h,0cah,0cbh,0cch,0cdh,0ceh,0cfh
  279.            db     0d0h,0d1h,0d2h,0d3h,0d4h,0d5h,0d6h,0d7h
  280.            db     0d8h,0d9h,0dah,0dbh,0dch,0ddh,0deh,0dfh
  281.            db     0e0h,0e1h,0e2h,0e3h,0e4h,0e5h,0e6h,0e7h
  282.            db     0e8h,0e9h,0eah,0ebh,0ech,0edh,0eeh,0efh
  283.            db     0f0h,0f1h,0f2h,0f3h,0f4h,0f5h,0f6h,0f7h
  284.            db     0f8h,0f9h,0fah,0fbh,0fch,0fdh,0feh,0ffh
  285. ;
  286. ; Modified 4/21/93 to handle up to base 36!
  287. ;
  288. ValueTable     db     02ch    dup(0ffh)
  289.            db     0feh,0fdh,0feh,0ffh        ; skip , and .
  290.            db     0,1,2,3,4,5,6,7,8,9
  291.            db     007h    dup(0ffh)
  292.            db     10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
  293.            db     27,28,29,30,31,32,33,34,35
  294.            db     006h    dup(0ffh)
  295.            db     10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
  296.            db     27,28,29,30,31,32,33,34,35
  297.            db     085h    dup(0ffh)
  298.  
  299.  
  300. strbuffer      db     104h dup(?)   ; temporary string buffer
  301. numbuffer      db     104h dup(?)   ; for number strings for debugging
  302.  
  303. number_fill    db     30h           ; '0'
  304. table          db     '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  305. Debug          dd     0             ; True if debugging
  306.  
  307. ExitCode       dd     0             ; Exit code passed to OS/2 after BYE
  308.  
  309. CommandStr     db     100h dup(?)
  310. CommandLen     EQU    $-CommandStr
  311.  
  312. OurStack       dd     STACK_SIZE dup(?)  ; should be big enough for a start
  313. FStackBase     dd     STACK_UNDERFLOW dup(?)   ; provide room for underflow
  314.  
  315.  
  316. ; DO NOT ADD ANY VARIABLES HERE.  Stack is relative to USER variables.
  317. ; USER Data Area Starts Here.  Not all the variables here are USER variables.
  318. ;   Some may be converted, others may not.
  319.  
  320. U_UserVPtr         dd      0           ; User variable pointer
  321. U_UserDefaultPtr   dd      0           ; Pointer to default USER variable area
  322. UserVPtr           EQU     U_UserVPtr USER
  323. UserDefaultPtr     EQU     U_UserDefaultPtr USER
  324.  
  325. U_StackBase        dd      FStackBase    ; Holds base address of stack
  326. StackBase          EQU     U_StackBase USER
  327.  
  328. U_TickAbort        dd      VecAbort      ; Pointer to code for ABORT
  329. TickAbort          EQU     U_TickAbort USER
  330.  
  331. CodeSpace          dd      0             ; Ptr to next avail. dictionary location
  332. NewWord            dd      ?             ; Header of very last word defined
  333.  
  334. CompileMode        dd      0             ; Non-zero if compiling
  335. U_LineNumber       dd      0             ; Line number of file being loaded
  336. LineNumber         EQU     U_LineNumber USER
  337.  
  338. U_TIB              dd      0             ; Address of Terminal Input Buffer
  339. TIB                EQU     U_TIB USER
  340. U_NTIB             dd      0             ; Number of characters input
  341. NTIB               EQU     U_NTIB USER
  342. U_Offsett          dd      0             ; Offset from start of buffer
  343. Offsett            EQU     U_Offsett USER
  344.  
  345. U_number_base      dd      10            ; Decimal
  346. number_base        EQU     U_number_base ; Should be a USER, change _NumberQ 1st
  347. OkVal              dd      0
  348. Value              dd      0
  349. Negative           dd      0
  350. DPL                dd      0
  351.  
  352. U_SysTo            dd      0          ; TO variables: 0=fetch; 1=store; -1=add
  353. SysTo              EQU     U_SysTo USER
  354. U_OutPos           dd      0          ; Output position
  355. OutPos             EQU     U_OutPos USER
  356. CharPerLine        dd      80
  357.  
  358. FoundAddr          dd      0
  359. Current            dd      ForthLink   ; Vocabulary where definitions are created
  360. Context            dd      ForthLink,SysLink, ContextSize dup (0)
  361.                            ; Context is where searching dictionary starts
  362.  
  363. UserArea           dd      UserAreaSize dup (0)
  364.  
  365. ; END OF USER VARIABLES
  366. ;StackBase      dd      FStackBase    ; Holds base address of stack
  367. ;TickAbort      dd      VecAbort      ; Pointer to code for ABORT
  368. ;
  369. ;CodeSpace      dd      0             ; Ptr to next avail. dictionary location
  370. ;NewWord        dd      ?             ; Header of very last word defined
  371. ;
  372. ;CompileMode    dd      0             ; Non-zero if compiling
  373. ;LineNumber     dd      0             ; Line number of file being loaded
  374. ;
  375. ;number_base    dd      10            ; Decimal
  376. ;OkVal          dd      0
  377. ;Value          dd      0
  378. ;Negative       dd      0
  379. ;DPL            dd      0
  380. ;
  381. ;SysTo          dd      0          ; TO variables: 0=fetch; 1=store; -1=add
  382. ;OutPos         dd      0          ; Output position
  383. OutLine        dd      0          ; counts UP
  384. ;CharPerLine    dd      80
  385. MoreLength     dd      22
  386. MoreVector     dd      Pause
  387.  
  388. TickExecute    dd      _DoExecute
  389.  
  390. ;FoundAddr      dd      0
  391. ;Current        dd      ForthLink   ; Vocabulary where definitions are created
  392. ;Context        dd      ForthLink,SysLink, ContextSize dup (0)
  393.                ; Context is where searching dictionary starts
  394.  
  395. ForthLink      dd      0,LastForthWord,0       ; FORTH vocabulary pointer
  396. SysLink        dd      0,LastHeader,ForthLink  ; SYSTEM vocabulary pointer
  397. Voc_link       dd      SysLink           ; Pointer to last vocabulary created
  398.  
  399. FopenAction    dd      0
  400. FopenHandle    dd      0
  401. FopenName      db     "FORTH.INI",0
  402.            db      80 dup (?)
  403.  
  404. FileBufferSize =      16384
  405. FileBuffer     db     FileBufferSize dup (?)
  406.  
  407. Date1          equ    <>
  408. Date1          CatStr <">, @Date, <">
  409.  
  410. Paren1         equ    <>
  411. Paren1         CatStr <(>
  412.  
  413. MESSAGE        Version," (Compiled: ",Date1,")",CrLf
  414.  
  415.  
  416. InputBufferSize =      1024
  417. InputSpace     db      InputBufferSize dup (?)
  418. InputBuffer    dd      Offset InputSpace
  419. InputCount     dd      0
  420. InputOffset    dd      0
  421.  
  422. LastWordEnd    dd      0
  423.  
  424. ;
  425. ; END OF FORTH SOURCE.....
  426. ;
  427.  
  428.            .CODE
  429.  
  430. BREAK          MACRO
  431.            Call   Do_Breakpoint
  432.            ENDM
  433.  
  434. IMMEDIATE      EQU     1
  435. COMPILEONLY    EQU     2
  436. HIDDEN         EQU     4
  437.  
  438.  
  439. _HEADER        STRUC
  440.   Prev           DWORD  ?
  441.   Flags          DWORD  ?     ; Not immediate, function call
  442.   CodePointer    DWORD  ?
  443.   NameSize       DWORD  ?
  444.   ThisName       BYTE   20h dup (?)
  445. _HEADER        ENDS
  446.  
  447.  
  448. LASTHEADER     =       0
  449.  
  450. CodeDef        MACRO   ThisName:Req,Flg := <0>
  451.            LOCAL   ThisOne,ThisCode
  452.  
  453.   ThisOne      _HEADER { LastHeader, (Flg), ThisCode,@SIZESTR(ThisName)-2,ThisName }
  454.   LASTHEADER   =       ThisOne
  455.  
  456.   ThisCode:
  457.            ENDM
  458.  
  459.            .code
  460. ;*****************************************
  461. ;*                                       *
  462. ;*            CORE VOCABULARY            *
  463. ;*                                       *
  464. ;*****************************************
  465.  
  466.                CodeDef 'NOP'
  467. DoNothing:     ret
  468.  
  469.            CodeDef '!'
  470. Store:         mov     edx,[ebx  ] ; value addr .... poke
  471.            mov     eax,[ebx+4]
  472.            mov     [edx],eax
  473.            add     ebx,8       ; pop both values
  474.            ret
  475.  
  476.            CodeDef "'"              ; Tick, return address of next word
  477. Tick:          mov     eax,' '
  478.            PushForth
  479.            Call    _Word
  480.            Call    _Find
  481.            PullForth
  482.            and     eax,eax
  483.            jz      @f
  484.            ret
  485.  
  486. @@:            lea     edx,What1Msg
  487.            call    WriteStr
  488.            call    _Count
  489.            call    _Type
  490.            lea     edx,What2Msg
  491.            call    WriteStr
  492.            jmp     Abort
  493.  
  494.  
  495. _Comment       _Header { LastHeader, Immediate, Do_Comment, 1, '(' }
  496. LastHeader     =       _Comment
  497.  
  498.  
  499. Do_Comment:    mov     esi,InputBuffer
  500.            add     esi,InputOffset
  501.            mov     ecx,InputCount
  502.            sub     ecx,InputOffset
  503.            jbe     CommentDone
  504.  
  505. @@:            lodsb
  506.            cmp     al,')'
  507.            loopne  @b
  508.  
  509. CommentDone:   sub     esi,Inputbuffer
  510.            mov     inputoffset,esi
  511.            ret
  512.  
  513.  
  514.  
  515.            CodeDef '*'
  516.            PULLFORTH
  517.            imul    eax,[ebx]
  518.            mov     [ebx],eax
  519.            ret
  520.  
  521.            CodeDef '*/'           ; ( a b c -- a*b/c )
  522.                mov     eax,[ebx+8]
  523.                mov     edx,[ebx+4]
  524.                mov     ecx,[ebx+0]
  525.                or      ecx,ecx
  526.                jz      DivByZero
  527.                add     ebx,8          ; we eat 2 more than we make
  528.                imul    edx
  529.                idiv    ecx
  530.                mov     [ebx+0],eax
  531.            ret
  532.  
  533.            CodeDef '*/MOD'        ; ( a b c -- a*b/c a*b mod c )
  534.                mov     eax,[ebx+8]
  535.                mov     edx,[ebx+4]
  536.                mov     ecx,[ebx+0]
  537.                or      ecx,ecx
  538.                jz      DivByZero
  539.                add     ebx,4          ; we eat 2 more than we make
  540.                imul    edx
  541.                idiv    ecx
  542.                mov     [ebx+4],edx    ; remainder
  543.                mov     [ebx+0],eax    ; quotient  on "TOP"
  544.            ret
  545.  
  546.            CodeDef '+'
  547.            PULLFORTH
  548.            add     [ebx],eax
  549.            ret
  550.  
  551.            CodeDef '+!'          ; ( n addr -- ) adds n to addr
  552. PlusStore:     mov     edx,[ebx  ]
  553.            mov     eax,[ebx+4]
  554.            add     [edx],eax
  555.            add     ebx,8
  556.            ret
  557.  
  558.            CodeDef ','           ; ( Compiles a CELL )
  559. Comma:         cld
  560.            PULLFORTH
  561.            stosd
  562.            mov     CodeSpace,EDI
  563.            ret
  564.  
  565.            CodeDef '-'           ; ( n1 n2 -- n1-n2 )
  566.            PULLFORTH
  567.            sub     [ebx],eax
  568.            ret
  569.  
  570.            CodeDef '."',3           ; Immediate, Compile Only
  571.            Call    S_Quote
  572.            lea     eax,_Type
  573.            PushForth
  574.            call    Do_CompileCall
  575.            ret
  576.  
  577.            CodeDef '/'
  578.            PULLFORTH
  579.            or      eax,eax
  580.            jz      DivByZero
  581.            xchg    eax,[ebx]
  582.            CDQ                     ; convert AX to DX:AX
  583.            idiv    DWORD PTR[ebx]
  584.            mov     [ebx],eax
  585.            ret
  586.  
  587.            CodeDef '/MOD'          ; ( a b -- {a mod b}  {a div b} )
  588.            mov     eax,[ebx]       ; one up on the stack
  589.            or      eax,eax
  590.            jz      DivByZero
  591.            xchg    eax,[ebx+4]
  592.            CDQ                     ; convert AX to DX:AX
  593.            idiv    DWORD PTR[ebx+4]
  594.            mov     [ebx],eax       ; Store quotient
  595.            mov     [ebx+4],edx     ; Store remainder
  596.            ret
  597.  
  598.            CodeDef 'SM/REM'        ; ( D n -- {D mod n}  {D div n} )
  599.                push    ecx
  600.                push    edx
  601.                PullForth
  602.                mov     ecx,eax         ; ecx <-- n
  603.                PullForth
  604.                mov     edx,eax         ; Top half in edx
  605.                PullForth               ; bottom in eax
  606.                idiv    ecx
  607.                xchg    eax,edx         ; swap the result order
  608.                PushForth
  609.                mov     eax,edx
  610.                PushForth               ; push the other answer
  611.                pop     edx
  612.                pop     ecx
  613.                ret
  614.  
  615.            CodeDef 'UM/MOD'        ; ( D n -- {D mod n}  {D div n} )
  616.                push    ecx
  617.                push    edx
  618.                PullForth
  619.                mov     ecx,eax         ; ecx <-- n
  620.                PullForth
  621.                mov     edx,eax         ; Top half in edx
  622.                PullForth               ; bottom in eax
  623.                div     ecx
  624.                xchg    eax,edx         ; swap the result order
  625.                PushForth
  626.                mov     eax,edx
  627.                PushForth               ; push the other answer
  628.                pop     edx
  629.                pop     ecx
  630.                ret
  631.  
  632.                CodeDef 'FM/MOD'        ; ( D n -- {D mov n}  {D div n} )
  633.                push    ecx
  634.                push    edx
  635.                mov     ecx,[ebx+0]     ; n is on "top"
  636.                mov     edx,[ebx+4]     ; D msw
  637.                mov     eax,[ebx+8]     ; D lsw
  638.                add     ebx,4           ; we will consume 1 more than we make
  639.  
  640.                or      ecx,ecx
  641.                jz      DivByZero       ; don't even attempt it if = 0
  642.                js      @f
  643.                or      edx,edx
  644.                jns     DivQ1           ; +/+
  645.                jmp     DivQ2           ; -/+
  646.  
  647. @@:            or      edx,edx
  648.                jns     DivQ3           ; +/-
  649.                jmp     DivQ4           ; -/-
  650.  
  651.  
  652. DivQ1:         div     ecx             ; +/+, simple math
  653. DivDone:       mov     [ebx+0],eax
  654.                mov     [ebx+4],edx
  655.                pop     edx
  656.                pop     ecx
  657.                ret
  658.  
  659.  
  660. DivQ2:         not     eax             ; -/+   Negate EDX:EAX
  661.                not     edx
  662.                add     eax,1
  663.                adc     edx,0
  664.                div     ecx
  665.                neg     eax             ; neg quotient
  666.                or      edx,edx
  667.                jz      @f
  668.                sub     edx,ecx         ; dec remainder my divisor
  669.                dec     eax             ; dec quotient by 1
  670.                neg     edx             ; negate divisor
  671. @@:            jmp     DivDone
  672.  
  673. DivQ3:         neg     ecx             ; +/-   Negate cx
  674.                div     ecx
  675.                neg     eax             ; neg quotient
  676.                or      edx,edx
  677.                jz      @f
  678.                sub     edx,ecx         ; dec remainder my divisor
  679.                dec     eax             ; dec quotient by 1
  680. @@:            jmp     DivDone
  681.  
  682. DivQ4:         neg     ecx             ; -/-   Negate cx
  683.                not     eax             ; negate dx:ax, 1's comp
  684.                not     edx
  685.                add     eax,1           ; and add +1
  686.                adc     edx,0
  687.                div     ecx             ; do the division
  688.                neg     edx             ; negate remainder
  689.                jmp     DivDone         ; whew!
  690.  
  691.  
  692.  
  693.  
  694.  
  695.            CodeDef '0<'
  696.            xor     eax,eax
  697.            jmp     LessThan
  698.  
  699.            CodeDef '0='            ; returns true if A = 0
  700.            xor     eax,eax
  701.            cmp     eax,[ebx]
  702.            jnz     @f
  703.            not     eax
  704. @@:            mov     [ebx],eax
  705.            ret
  706.  
  707.            CodeDef '1+'
  708.            mov     eax,1
  709.            add     [ebx],eax
  710.            ret
  711.  
  712.            CodeDef '1-'
  713.            mov     eax,1
  714.            sub     [ebx],eax
  715.            ret
  716.  
  717.            CodeDef '2!'    ; ( x1 x2 a-addr -- )
  718.            mov     edx,[ebx]            ; MAW - ANSforth Fix 10/23/93
  719.            mov     eax,[ebx+4]
  720.            mov     [edx],eax
  721.            mov     eax,[ebx+8]
  722.            mov     [edx+4],eax
  723.            add     ebx,12
  724.            ret
  725.  
  726.            CodeDef '2*'
  727.            shl     DWORD PTR[ebx],1
  728.            ret
  729.  
  730.            CodeDef '2/'
  731.            sar     DWORD PTR[ebx],1     ; MAW - ANSforth Fix 6/8/93
  732.            ret
  733.  
  734.            CodeDef '2@'
  735.                PullForth                    ; MAW - ANSforth Fix 10/23/93
  736.                mov     edx,eax
  737.                mov     eax,[edx+4]
  738.                PushForth
  739.                mov     eax,[edx]
  740.                PushForth
  741.            ret
  742.  
  743.            CodeDef '2DROP'
  744.            add     ebx,8
  745.            ret
  746.  
  747.            CodeDef '2DUP'
  748.            mov     eax,[ebx+4]
  749.            mov     edx,[ebx]
  750.            PushForth
  751.            sub     ebx,4
  752.            mov     [ebx],edx
  753.            ret
  754.  
  755.            CodeDef '2OVER'
  756.            mov     eax,[ebx+12]
  757.            mov     ecx,[ebx+8]
  758.            sub     ebx,8
  759.            mov     [ebx],ecx
  760.            mov     [ebx+4],eax
  761.            ret
  762.  
  763.            CodeDef '2SWAP'
  764.            mov     ecx,[ebx]
  765.            mov     edx,[ebx+4]
  766.            mov     eax,[ebx+8]
  767.            mov     [ebx],eax
  768.            mov     eax,[ebx+12]
  769.            mov     [ebx+4],eax
  770.            mov     [ebx+8],ecx
  771.            mov     [ebx+12],edx
  772.            ret
  773.  
  774.            CodeDef ':'
  775. Do_Colon:      mov     eax,CompileMode
  776.            or      eax,eax
  777.            jnz     NoSemicolon
  778.            mov     EDI,CodeSpace
  779.            mov     NewWord,EDI
  780.            cld
  781.            mov     eax,Current
  782.            mov     eax,[eax+VocLinkOffset]
  783.            stosd                    ; Store the pointer to previous
  784.            mov     eax,0            ; Flags to store
  785.            stosd                    ; Store the Words flags
  786.            mov     eax,0            ; Execution Address (0 for now)
  787.            push    edi              ; save this address for a while
  788.            stosd                    ; Store the code address
  789.            mov     edx,edi
  790.            mov     eax,' '
  791.            PushForth
  792.            Call    _Word            ; Get string, stored at EDI!
  793.            mov     edi,LastWordEnd  ; Get the end of the string
  794.            Call    ToUpper          ; (Uses address from forth stack)
  795.            pop     eax              ; Get the place to stuff code address
  796.  
  797.            mov     edi,eax          ; Fix so headers are always
  798.            add     edi,024h         ; the same size
  799.  
  800.            mov     [eax],edi        ; Update the code address
  801.            mov     CompileMode,1    ; We are now in compile mode
  802.            ret                      ; done for now
  803.  
  804.                CodeDef ':NONAME'
  805. Colon_NoName:  mov     eax,CompileMode
  806.            or      eax,eax
  807.            jnz     NoSemicolon
  808.            mov     EDI,CodeSpace
  809.                mov     eax,edi          ; Get adress of start in eax
  810.                PushForth
  811.                mov     CompileMode,1
  812.                ret
  813.  
  814. NoSemicolon:   lea     edx,SemicolonMsg
  815.            call    WriteStr
  816.            call    WriteLineNum
  817.            jmp     Abort
  818.  
  819.            CodeDef ';',3
  820. Do_SemiColon:
  821.            call    CompileCheck     ; finish a definition
  822.            call    Do_CompileRet    ; update codespace
  823.            mov     CodeSpace,EDI
  824.            mov     eax,NewWord      ; update the dictionary
  825.            mov     edx,Current
  826.            mov     [edx+VocLinkOffset],eax ; update Current vocab ptr
  827.            mov     CompileMode,0    ; back out of compile mode
  828.            ret
  829.  
  830. Do_CompileRet:                         ; compiles a RET instruction
  831.            mov     al,0C3h
  832.            stosb
  833.            ret
  834.  
  835.            CodeDef '<'             ; i.e. 0 0 <
  836.            pullforth               ; eax = stack top 0
  837. LessThan:      cmp     eax,[ebx]       ; subtract 0 --> -1 (carry set)
  838.            mov     eax,0           ; eax = 0
  839.            jle     @f
  840.            dec     eax
  841. @@:            mov     [ebx],eax
  842.            ret
  843.  
  844.            CodeDef '='             ; returns true if A = B
  845.            pullforth
  846.            cmp     eax,[ebx]
  847.            mov     eax,0
  848.            jnz     @f
  849.            not     eax
  850. @@:            mov     [ebx],eax
  851.            ret
  852.  
  853.            CodeDef '>'             ; i.e. 9 4 >
  854.            pullforth               ; eax = stack top 4
  855. GreaterThan:   cmp     eax,[ebx]       ; subtract 9 --> -5 (carry set)
  856.            mov     eax,0           ; eax = 0
  857.            jge     @f
  858.            dec     eax
  859. @@:            mov     [ebx],eax
  860.            ret
  861.  
  862.            CodeDef '>BODY'         ; ( xt -- a-addr )
  863.            PullForth               ; do an execute
  864.            cmp     byte ptr[eax],0E8h
  865.            jnz     @f
  866.                add     eax,5
  867.                PushForth
  868.                ret
  869.  
  870. @@:            lea     edx,NotCreateWordMsg
  871.            call    WriteStr
  872.            jmp     Abort
  873.  
  874.            CodeDef '>IN'           ; Address of offset into buffer
  875.            lea     eax,InputOffset
  876.            pushForth
  877.            ret
  878.  
  879.            CodeDef '>R'       ; moves top of stack to return stack
  880.            pop     edx        ; our return address
  881.            PULLFORTH
  882.            push    eax        ; push number onto return stack
  883.            push    edx        ; restore return address and push on stack
  884.            ret
  885.  
  886.            CodeDef '?DUP'      ; Duplicates if true
  887.            mov     eax,[ebx]
  888.            or      eax,eax
  889.            jz      @f
  890.            PushForth
  891. @@:            ret
  892.  
  893.            CodeDef '@'
  894. Fetch:         mov     eax,[ebx  ]
  895.            mov     eax,[eax  ]
  896.            mov     [ebx  ],eax
  897.            ret
  898.  
  899.            CodeDef 'ABS'          ; ( a -- |a| )
  900.            mov     eax,[ebx]
  901.            and     eax,eax
  902.            jns     @f
  903.            neg     eax
  904.            mov     [ebx],eax
  905. @@:            ret
  906.  
  907.            CodeDef 'ACCEPT'     ; ( c-addr n1 -- n2 ) Get a string from
  908.                     ; standard input, using READ
  909. _Accept:       mov     edx,[ebx+4]  ; Buffer address in EDX
  910.            mov     eax,[ebx]    ; Buffer size in eax
  911.            add     ebx,4        ; consume 1 param, replace second
  912.            pushad               ; save all the registers
  913.            push    ebx          ; Return parameter is bytes read
  914.            push    eax          ; Size of buffer
  915.            push    edx          ; Buffer area
  916.            pushd   STDIN
  917.            call    Dos32Read
  918.            add     esp,16
  919.            or      eax,eax
  920.            jnz     IOerror
  921.            popad
  922.            ret
  923.  
  924.            CodeDef 'ALIGN'      ; ( -- )
  925.            sub     ebx,4
  926.            mov     [ebx],edi
  927.            call    Aligned
  928.            mov     edi,[ebx]
  929.            add     ebx,4
  930.            mov     CodeSpace,edi
  931.            ret
  932.  
  933.            CodeDef 'ALIGNED'    ; ( addr -- a-addr )
  934. Aligned:       mov     eax,[ebx]
  935.            and     eax,3
  936.            sub     eax,4
  937.            neg     eax
  938.            and     eax,3
  939.            add     [ebx],eax
  940.            ret
  941.  
  942.            CodeDef 'ALLOT'          ; add N bytes to the latest entry
  943. Allot:         PULLFORTH
  944.            add     EDI,EAX
  945.            mov     CodeSpace,EDI
  946.            ret
  947.  
  948.            CodeDef 'AND'
  949.            PULLFORTH
  950.            AND     [ebx],eax
  951.            ret
  952.  
  953.            CodeDef 'BASE'
  954.            lea     eax,Number_Base
  955.            PUSHFORTH
  956.            ret
  957.  
  958.            CodeDef 'BL'
  959.            mov     eax,' '
  960.            PUSHFORTH
  961.            ret
  962.  
  963.            CodeDef 'C!'
  964.            mov     edx,[ebx  ]      ; value addr .... poke
  965.            mov     eax,[ebx+4]
  966.            mov     [edx],al
  967.            add     ebx,8            ; pop both values
  968.            ret
  969.  
  970.            CodeDef 'C,'
  971.            cld
  972.            PULLFORTH
  973.            stosb
  974.            mov     CodeSpace,EDI
  975.            ret
  976.  
  977.            CodeDef 'C@'
  978.            mov     eax,[ebx  ]
  979.            mov     eax,[eax  ]
  980.            and     eax,00ffh
  981.            mov     [ebx  ],eax
  982.            ret
  983.  
  984.            CodeDef 'CELL+'
  985.            mov     eax,[ebx]
  986.            add     eax,4
  987.            mov     [ebx],eax
  988.            ret
  989.  
  990.            CodeDef 'CELLS'       ; multiplies by word size, 4
  991. WTimes:        shl     DWORD PTR [ebx],2
  992.            ret
  993.  
  994.            CodeDef 'CHAR'        ; ( "name" -- char )
  995. DoChar:        mov     eax,' '
  996.            PushForth
  997.            call    _Word
  998.                mov     edx,[ebx]
  999.                xor     eax,eax
  1000.                mov     al,[edx+4]
  1001.                mov     [ebx],eax
  1002.            ret
  1003.  
  1004.            CodeDef 'CHAR+'
  1005.            inc     dword ptr[ebx]
  1006.            ret
  1007.  
  1008.            CodeDef 'CHARS'
  1009.            ret
  1010.  
  1011.            CodeDef 'CONSTANT'       ; Declare a constant
  1012. Do_Constant:   mov     EDI,CodeSpace
  1013.            mov     NewWord,EDI      ; Save start of word
  1014.            cld
  1015.            mov     eax,Current
  1016.            mov     eax,[eax+VocLinkOffset]
  1017.            stosd                    ; Store the pointer to previous
  1018.            mov     eax,0            ; Flags to store
  1019.            stosd                    ; Store the Words flags
  1020.            mov     eax,0            ; Execution Address (0 for now)
  1021.            push    edi              ; save this address for a while
  1022.            stosd                    ; Store the code address
  1023.            mov     edx,edi
  1024.            mov     eax,' '
  1025.            PushForth
  1026.            Call    _Word            ; Get string, stored at EDI!
  1027.            mov     edi,LastWordEnd  ; Get the end of the string
  1028.            Call    ToUpper          ; (Uses address from forth stack)
  1029.            pop     eax              ; Get the place to stuff code address
  1030.            mov     [eax],edi        ; Update the code address
  1031.  
  1032.            mov     al,0E8h          ; Call ABSOLUTE
  1033.            stosb
  1034.            lea     eax,DoesConstant ; Address of DoesConst routine
  1035.            sub     eax,EDI          ; subtract current EIP
  1036.            sub     eax,4            ; subtract 4 for upcoming offset
  1037.            STOSD
  1038.  
  1039.            PULLFORTH                ; Store the constant
  1040.            STOSD
  1041.  
  1042.            mov     eax,NewWord      ; update the dictionary
  1043.            mov     edx,Current
  1044.            mov     [edx+VocLinkOffset],eax
  1045.            mov     CodeSpace,EDI
  1046.            ret                      ; done for now
  1047.  
  1048. DoesConstant:  pop     eax
  1049.            mov     eax,[eax]
  1050.            PUSHFORTH
  1051.            ret
  1052.  
  1053.            CodeDef 'CR'
  1054. DoCr:          lea     edx,CrLfStr       ; Write a CR/LF pair
  1055.            call    WriteStr
  1056.            xor     eax,eax
  1057.            mov     DWORD PTR OutPos,eax
  1058.                inc     DWORD PTR OutLine
  1059.            ret
  1060.  
  1061.            CodeDef 'CREATE'         ; Creates a 0 byte variable
  1062. Create:        mov     EDI,CodeSpace
  1063.            mov     NewWord,EDI      ; Save start of word
  1064.            cld
  1065.            mov     eax,Current
  1066.            mov     eax,[eax+VocLinkOffset]
  1067.            stosd                    ; Store the pointer to previous
  1068.            mov     eax,0            ; Flags to store
  1069.            stosd                    ; Store the Words flags
  1070.            mov     eax,0            ; Execution Address (0 for now)
  1071.            push    edi              ; save this address for a while
  1072.            stosd                    ; Store the code address
  1073.            mov     edx,edi
  1074.            mov     eax,' '
  1075.            PushForth
  1076.            Call    _Word            ; Get string, stored at EDI!
  1077.            mov     edi,LastWordEnd  ; Get the end of the string
  1078.            Call    ToUpper          ; (Uses address from forth stack)
  1079.            pop     eax              ; Get the place to stuff code address
  1080.            mov     [eax],edi        ; Update the code address
  1081.  
  1082.            mov     al,0E8h          ; Call ABSOLUTE
  1083.            stosb
  1084.            lea     eax,DoesVariable ; Address of DoesConst routine
  1085.            sub     eax,EDI          ; subtract current EIP
  1086.            sub     eax,4            ; subtract 4 for upcoming offset
  1087.            stosd
  1088.  
  1089.            mov     CodeSpace,EDI
  1090.            mov     eax,NewWord      ; update the dictionary
  1091.            mov     edx,Current
  1092.            mov     [edx+VocLinkOffset],eax
  1093.            ret                      ; done for now
  1094.  
  1095.  
  1096.  
  1097.            CodeDef 'COUNT'     ; ( addr -- addr+4 [addr] )
  1098. _Count:        mov     edx,[ebx]
  1099.            xor     eax,eax
  1100.            mov     eax,[edx]
  1101.            add     DWORD PTR [ebx],4
  1102.            PushForth
  1103.            ret
  1104.  
  1105.            CodeDef 'DECIMAL'
  1106.            mov     eax,10
  1107.            mov     Number_Base,eax
  1108.            ret
  1109.  
  1110.            CodeDef 'DEPTH'
  1111.            mov     eax,StackBase
  1112.            sub     eax,ebx         ; Forth Stack depth in EAX
  1113.            clc
  1114.            shr     eax,2           ; divide by entry size
  1115.            PUSHFORTH
  1116.            ret
  1117.  
  1118.            CodeDef 'DROP'
  1119. Drop:          add     ebx,4           ; Drop Stack top
  1120.            ret
  1121.  
  1122.            CodeDef 'DUP'
  1123.            mov     eax,[ebx]
  1124.            PUSHFORTH
  1125.            ret
  1126.  
  1127.            CodeDef 'EMIT'           ; Quite large, isn't it?
  1128. Do_Emit:       push    ebp
  1129.            push    edi
  1130.            push    esi
  1131.            push    edx
  1132.            push    ecx
  1133.            mov     eax,esp          ; save current ss, esp
  1134.            push    ss               ; for return from 16-bit land
  1135.            push    eax
  1136.  
  1137.            mov     ecx,OutPos
  1138.            inc     ecx
  1139.            mov     OutPos,ecx
  1140.  
  1141.            PULLFORTH
  1142.  
  1143.            push    eax
  1144.            mov     eax,esp          ; character stored at [EAX]
  1145.            call    DosFlatToSel
  1146.            push    eax              ; address of string
  1147.            pushw   1                ; length of string
  1148.            pushw   0                ; vio handle (0 = default)
  1149.  
  1150.            mov     eax,esp          ; convert stack so 16-bit can use it
  1151.            ror     eax,16
  1152.            shl     eax,3
  1153.            or      al,7             ; convert to ring-3 tiled segment
  1154.            mov     ss,eax
  1155.  
  1156.            jmp     far ptr Do_Emit16
  1157.  
  1158. Do_Emit2       label   far
  1159.            movzx   eax,ax           ; convert return code to 32-bit
  1160.  
  1161. ; Restore 32-bit SS:ESP - it is on top of stack.
  1162.            movzx   esp,sp           ; make sure that esp is correct
  1163.            lss     esp,[esp]
  1164.            pop     ecx
  1165.            pop     edx
  1166.            pop     esi
  1167.            pop     edi
  1168.            pop     ebp
  1169.            ret
  1170.  
  1171.            CodeDef '<EXECUTE>'      ; The REAL execute
  1172. _DoExecute:    PullForth
  1173.            jmp     eax
  1174.  
  1175.            CodeDef "'EXECUTE"       ; Gives address of vector
  1176.            lea     eax,TickExecute
  1177.            PushForth
  1178.            ret
  1179.  
  1180.            CodeDef 'EXECUTE'        ; ( addr -- )
  1181. _Execute:      mov     eax,TickExecute
  1182.            jmp     eax              ; Jump to address specified
  1183.  
  1184.            CodeDef 'FIND'           ; ( c-addr -- c-addr 0 | xt 1 | xt -1 )
  1185. _Find:         mov     edx,[ebx]        ; copy out of the stack, don't destroy
  1186.            call    LookFor
  1187.            mov     eax,FoundAddr
  1188.            or      eax,eax
  1189.            jz      FindDone
  1190.                mov     ecx,eax
  1191.            mov     edx,[ecx].CodePointer
  1192.                mov     [ebx],edx        ; overwrite with execution address
  1193.            mov     edx,[ecx].Flags
  1194.            and     edx,IMMEDIATE
  1195.            jnz     FindImm
  1196.            mov     eax,-1
  1197.            jmp     FindDone
  1198. FindImm:       mov     eax,1
  1199. FindDone:      PushForth
  1200.            ret
  1201.  
  1202.  
  1203.            CodeDef 'FILL'    ; ( addr n b -- ) fills n bytes at addr with b
  1204.            mov     eax,[ebx+4]
  1205.            cmp     eax,1      ; not defined for n < 1
  1206.            jl      @f
  1207.            push    edi
  1208.            mov     ecx,eax
  1209.            mov     eax,[ebx]
  1210.            mov     edi,[ebx+8]
  1211.            rep stosb
  1212.            pop     edi
  1213. @@:            add     ebx,12
  1214.            ret
  1215.  
  1216.            CodeDef 'HERE'
  1217.            mov     eax,EDI
  1218.            PushForth
  1219.            ret
  1220.  
  1221.            CodeDef 'I'         ; copies number from return stack to top of stack
  1222.            mov     eax,[esp+4] ; Get the data
  1223.            PUSHFORTH
  1224.            ret
  1225.  
  1226.            CodeDef 'IMMEDIATE'
  1227.            mov     eax,Current
  1228.            mov     eax,[eax+VocLinkOffset]
  1229.            or      [EAX].Flags,Immediate
  1230.            ret
  1231.  
  1232.            CodeDef 'INVERT'       ; 1s complement
  1233.            not     dword ptr[ebx]
  1234.            ret
  1235.  
  1236.            CodeDef 'J'         ; 1 loop up
  1237.            mov     eax,[esp+12] ; return, index, limit, index
  1238.            PushForth
  1239.            ret
  1240.  
  1241.            CodeDef 'KEY'
  1242. GetKey:           mov     eax,0
  1243.            PushForth
  1244.            call    Do_Getkey
  1245.            ret
  1246.  
  1247.            CodeDef 'KEYNOWAIT'
  1248.            mov     eax,1
  1249.            PushForth
  1250.            call    Do_Getkey
  1251.            ret
  1252.  
  1253. ;               CodeDef '(KEY)'           ; New version of KEY
  1254. Do_GetKey:     PUSHAD
  1255.            mov     eax,esp          ; save current ss, esp
  1256.            push    ss               ; for return from 16-bit land
  1257.            push    eax
  1258.  
  1259.            lea     eax,ascii
  1260.            mov     word ptr [eax],0
  1261.            call    DosFlatToSel
  1262.            push    eax              ; 8 bytes of parameters
  1263.            PullForth
  1264.            and     eax,1
  1265.            push    ax               ; Wait flag, etc.
  1266.            mov     eax,0
  1267.            push    ax               ; Handle 0
  1268.  
  1269.            mov     eax,esp          ; convert stack so 16-bit can use it
  1270.            ror     eax,16
  1271.            shl     eax,3
  1272.            or      al,7             ; convert to ring-3 tiled segment
  1273.            mov     ss,eax
  1274.            jmp     far ptr Do_GetKey16
  1275.  
  1276. Do_GetKey2     label   far              ; Restore 32-bit SS:ESP - it is on top of stack.
  1277.            movzx   esp,sp           ; make sure that esp is correct
  1278.            lss     esp,[esp]
  1279.            POPAD
  1280.            xor     eax,eax
  1281.            mov     ax,word ptr[ascii]
  1282.            mov     [ebx],eax        ; Replace stack contents
  1283.            ret
  1284.  
  1285.            CodeDef 'LITERAL',3
  1286. _Literal:      cld                      ; mov eax,literal
  1287.            mov     al,0b8h
  1288.            stosb
  1289.            PULLFORTH
  1290.            stosd
  1291.  
  1292.            mov     al,083h          ; sub ebx,4
  1293.            stosb
  1294.            mov     al,0ebh
  1295.            stosb
  1296.            mov     al,004h
  1297.            stosb
  1298.  
  1299.            mov     al,089h          ; mov [ebx],eax
  1300.            stosb
  1301.            mov     al,003h
  1302.            stosb
  1303.            ret
  1304.  
  1305.            CodeDef 'LSHIFT'     ; ( n1 n2 -- n3 ) Shift n1 left n2 times
  1306.            mov     ecx,[ebx]
  1307.            add     ebx,4
  1308.            shl     DWORD PTR [ebx],cl
  1309.            ret
  1310.  
  1311.            CodeDef 'M*'        ; ( n1 n2 -- d )
  1312.            mov     eax,[ebx+4]
  1313.            imul    DWORD PTR[ebx]
  1314.            mov     [ebx],edx
  1315.            mov     [ebx+4],eax
  1316.            ret
  1317.  
  1318.            CodeDef 'MAX'          ; ( a b -- max )
  1319.            PullForth
  1320.            cmp     eax,[ebx]
  1321.            jl      @f
  1322.            mov     [ebx],eax
  1323. @@:            ret
  1324.  
  1325.            CodeDef 'MIN'          ; ( a b -- min )
  1326.            PullForth
  1327.            cmp     eax,[ebx]
  1328.            jg      @f
  1329.            mov     [ebx],eax
  1330. @@:            ret
  1331.  
  1332.            CodeDef 'MOD'
  1333.            PULLFORTH
  1334.            or      eax,eax
  1335.            jz      DivByZero
  1336.            xchg    eax,[ebx]
  1337.            CDQ                     ; convert AX to DX:AX
  1338.            idiv    DWORD PTR[ebx]
  1339.            mov     [ebx],edx       ; put MODULUS on stack
  1340.            ret
  1341.  
  1342.            CodeDef 'MOVE'      ; ( addr1 addr2 u -- )
  1343.            mov     eax,[ebx+8]
  1344.            cmp     eax,[ebx+4]
  1345.            ja      Cmove
  1346.            add     eax,[ebx]
  1347.            cmp     eax,[ebx+4] ; cmp  addr1+u,addr2
  1348.            jg      CmoveBack
  1349.            jmp     Cmove
  1350.  
  1351.            CodeDef 'NEGATE'       ; ( a -- -a )
  1352.            neg     DWORD PTR[ebx]
  1353.            ret
  1354.  
  1355.            CodeDef 'OR'
  1356.            PULLFORTH
  1357.            OR      [ebx],eax
  1358.            ret
  1359.  
  1360.            CodeDef 'OVER'
  1361.            mov     eax,[ebx+4]     ; duplicate one entry down...
  1362.            PUSHFORTH
  1363.            ret
  1364.  
  1365.            CodeDef 'QUIT'
  1366. Quit:          mov     esp,SavedESP
  1367.            call    StackCheck
  1368.            call    Prompt
  1369.            Call    Query
  1370.            call    Interpret
  1371.            jmp     Quit
  1372.  
  1373.            CodeDef 'R>'       ; moves number from return stack to top of stack
  1374.            pop     edx        ; our return address
  1375.            pop     eax        ; number we want
  1376.            push    edx        ; restore return address and push on stack
  1377.            PUSHFORTH
  1378.            ret
  1379.  
  1380.            CodeDef 'R@'       ; Copies contents of return stack
  1381.            mov     eax,[esp+4]
  1382.            PushForth
  1383.            ret
  1384.  
  1385.            CodeDef 'RECURSE',3      ; Call the NEW word
  1386.            Call    CompileCheck
  1387.            mov     eax,NewWord
  1388.            mov     eax,[eax].codepointer
  1389.            PushForth
  1390.            Call    Do_CompileCall
  1391.            ret
  1392.  
  1393.            CodeDef 'ROT'
  1394.            mov     eax,[ebx]       ; take top, move it down 2 levels
  1395.            xchg    eax,[ebx+4]
  1396.            xchg    eax,[ebx+8]
  1397.            mov     [ebx],eax
  1398.            ret
  1399.  
  1400.            CodeDef 'RSHIFT'     ; ( n1 n2 -- n3 ) Shift n1 left n2 times
  1401.            mov     ecx,[ebx]
  1402.            add     ebx,4
  1403.            shr     DWORD PTR[ebx],cl
  1404.            ret
  1405.  
  1406.  
  1407.            CodeDef 'S"',3           ; Generates an INLINE string
  1408. S_Quote:       Call    CompileCheck
  1409.            lea     eax,Inline_String
  1410.            PushForth
  1411.            Call    Do_CompileCall
  1412.  
  1413.            mov     eax,'"'          ; get string, stored HERE!
  1414.            PushForth
  1415.            Call    _Word            ; Get string, stored at EDI!
  1416.            mov     edi,LastWordEnd  ; Get the end of the string
  1417.            PullForth
  1418.            ret
  1419.  
  1420.            CodeDef 'S>D'       ; ( n -- d )
  1421.            xor     eax,eax
  1422.            mov     edx,[ebx]
  1423.            or      edx,edx
  1424.            js      S2D1
  1425.            PUSHFORTH
  1426.            ret
  1427. S2D1:          dec     eax
  1428.            PUSHFORTH
  1429.            ret
  1430.  
  1431.            CodeDef 'SOURCE'     ; Returns input buffer address and count
  1432.            mov     eax,InputBuffer
  1433.            PushForth
  1434.            mov     eax,InputCount
  1435.            PushForth
  1436.            ret
  1437.  
  1438.            CodeDef 'STATE'
  1439.            lea     eax,CompileMode
  1440.            PUSHFORTH
  1441.            ret
  1442.  
  1443.            CodeDef 'SPACE'
  1444.            mov     eax,' '
  1445.            PushForth
  1446.            Call    Do_Emit
  1447.            ret
  1448.  
  1449.            CodeDef 'SPACES'
  1450.            PullForth
  1451.            mov     ecx,eax
  1452. @@:            mov     eax,' '
  1453.            PushForth
  1454.            Call    Do_Emit
  1455.            Loop    @b
  1456.            ret
  1457.  
  1458.            CodeDef 'SWAP'
  1459.            mov     eax,[ebx  ]
  1460.            mov     edx,[ebx+4]
  1461.            mov     [ebx  ],edx
  1462.            mov     [ebx+4],eax
  1463.            ret
  1464.  
  1465.            CodeDef 'TYPE'         ; ( addr +n -- )
  1466. _Type:         pushad
  1467.            xor     eax,eax      ; used as "actual count" storage
  1468.            push    eax
  1469.            mov     eax,esp      ; push the address of the previous push
  1470.            push    eax
  1471.            mov     eax,[ebx]    ; push the string length
  1472.            add     OutPos,eax   ; update output position
  1473.            push    eax
  1474.            mov     eax,[ebx+4]  ; push the string address
  1475.            push    eax
  1476.            pushd   stdout       ; push the handle to write to
  1477.            call    Dos32Write   ; do the write.
  1478.            add     esp,20       ; set the stack back to semi-normal
  1479.            popad
  1480.            add     ebx,8        ; Drop the 2 forth stack entries
  1481.            ret
  1482.  
  1483.            CodeDef 'U<'      ; unsigned comparison
  1484.            PullForth
  1485.            cmp     eax,[ebx]
  1486.            mov     eax,0
  1487.            jbe     @f
  1488.            dec     eax
  1489. @@:            mov     [ebx],eax
  1490.            ret
  1491.  
  1492.            CodeDef 'UM*'       ; ( u1 u2 -- ud )
  1493.            mov     eax,[ebx+4]
  1494.            mul     DWORD PTR[ebx]
  1495.            mov     [ebx],edx
  1496.            mov     [ebx+4],eax
  1497.            ret
  1498.  
  1499.            CodeDef 'VARIABLE'       ; Declare a variable
  1500.            call    Create
  1501.            xor     eax,eax
  1502.            mov     [edi],eax        ; initialize to 0
  1503.            mov     eax,4
  1504.            PUSHFORTH
  1505.            call    Allot
  1506.            ret
  1507.  
  1508.            CodeDef 'WORD'          ; (char -- c-addr)
  1509.                        ; Pull a string from between delimiters
  1510.                        ; in InputBuffer
  1511.  
  1512. _Word:         cld                     ; Count UP
  1513.            push    edi             ; Push destination, we'll need it
  1514.            xor     eax,eax
  1515.            stosd                   ; Put a 0 in the count
  1516.  
  1517.            PullForth
  1518.            Push    EBX
  1519.            lea     EBX,WordScanTable
  1520.            mov     edx,eax         ; Delimiter in dl
  1521.            mov     esi,InputOffset
  1522.            mov     ecx,InputCount
  1523.            sub     ecx,esi         ; bump down count
  1524.            jle     _WordDone
  1525.  
  1526.            add     esi,InputBuffer
  1527. @@:            or      ecx,ecx         ; If we are out of characters, exit
  1528.            jz      _WordDone
  1529.            lodsb                   ; skip leading matches
  1530.            xlat
  1531.            dec     ecx
  1532.            cmp     dl,al
  1533.            jz      @b
  1534.  
  1535. @@:            stosb                   ; process non-matches
  1536.            or      ecx,ecx
  1537.            jz      _WordDone
  1538.            lodsb
  1539.            xlat
  1540.            dec     ecx
  1541.            cmp     dl,al
  1542.            jnz     @b
  1543.  
  1544. _WordDone:     mov     eax,esi
  1545.            mov     esi,InputBuffer
  1546.            sub     eax,esi         ; eax now has the NEW offset
  1547.            mov     InputOffset,eax ; update value
  1548.  
  1549.            mov     ecx,edi         ; stuff a non-counted space after text
  1550.            xor     eax,eax
  1551.            stosd
  1552.            mov     eax,ecx
  1553.  
  1554.            mov     LastWordEnd,edi
  1555.            pop     ebx
  1556.            pop     edi             ; original value of EDI
  1557.            sub     eax,edi         ; how many bytes did we use?
  1558.            sub     eax,4           ; adjust for count bytes
  1559.            mov     [edi],eax
  1560.            mov     eax,edi         ; address of string now in eax
  1561.            PushForth
  1562.            ret
  1563.  
  1564.  
  1565.            CodeDef 'XOR'
  1566.            PULLFORTH
  1567.            XOR     [ebx],eax
  1568.            ret
  1569.  
  1570.            CodeDef '[',Immediate   ; This must be an IMMEDIATE word
  1571.            mov     CompileMode,0
  1572.            ret
  1573.  
  1574.            CodeDef "[']",Immediate
  1575.            call    CompileCheck
  1576.            call    Tick
  1577.            call    _Literal
  1578.            ret
  1579.  
  1580.            CodeDef '[CHAR]',Immediate
  1581.            call    CompileCheck
  1582.            call    DoChar
  1583.            call    _Literal
  1584.            ret
  1585.  
  1586.            CodeDef ']'
  1587.            mov     CompileMode,1
  1588.            ret
  1589.  
  1590.  
  1591. ;*****************************************
  1592. ;*                                       *
  1593. ;*            CORE EXTENSIONS            *
  1594. ;*                                       *
  1595. ;*****************************************
  1596.  
  1597.  
  1598.            CodeDef '#TIB'
  1599.            lea     eax,InputCount
  1600.            PushForth
  1601.            ret
  1602.  
  1603.            CodeDef 'SPAN'
  1604.            lea     eax,InputCount
  1605.            PushForth
  1606.            ret
  1607.  
  1608.            CodeDef 'TIB'
  1609.            lea     eax,InputBuffer
  1610.            PushForth
  1611.            ret
  1612.  
  1613.            CodeDef '\',IMMEDIATE   ; Single line comment
  1614.            cld                     ; Count UP
  1615.            mov     esi,InputOffset
  1616.            mov     ecx,InputCount
  1617.            sub     ecx,esi         ; bump down count
  1618.            jle     _CommentDone
  1619.  
  1620.            add     esi,InputBuffer
  1621. @@:            lodsb
  1622.            cmp     al,CR
  1623.            loopne  @b
  1624.  
  1625. _CommentDone:  mov     eax,esi
  1626.            sub     eax,InputBuffer
  1627.            mov     InputOffset,eax ; update value
  1628.            ret
  1629.  
  1630.            CodeDef 'QUERY'      ; ( -- ) Get a line of text
  1631. Query:         lea     eax,InputSpace
  1632.            mov     InputBuffer,eax
  1633.            PushForth
  1634.            mov     eax,InputBufferSize
  1635.            PushForth
  1636.            call    _Accept
  1637.            PullForth
  1638.            mov     InputCount,eax
  1639.            xor     eax,eax
  1640.            mov     InputOffset,eax
  1641.            ret
  1642.  
  1643.  
  1644. ;*****************************************
  1645. ;*                                       *
  1646. ;*            UTILITY ROUTINES           *
  1647. ;*                                       *
  1648. ;*****************************************
  1649.  
  1650.            CodeDef '="'        ; ( addr1 addr2 -- f )
  1651. EqualStr:      push    esi
  1652.            push    edx
  1653.            push    ecx
  1654.            mov     esi,[ebx]
  1655.            add     ebx,4
  1656.            mov     edx,[ebx]
  1657.            push    ebx         ; Save STACK, we're using EBX
  1658.            lea     ebx,UpperCaseTable
  1659.            cld
  1660.            lodsd               ; Length of string1 in eax
  1661.            cmp     eax,[edx]   ; compare string lengths
  1662.            jnz     NotEqual
  1663.            add     edx,4       ; bump String2 pointer
  1664.            mov     ecx,eax     ; put the counter in ECX, for LOOP
  1665.  
  1666. EqualStr1:     lodsb
  1667.            xlat
  1668.            xchg    ah,al
  1669.            mov     al,[edx]
  1670.            xlat
  1671.            inc     edx
  1672.            cmp     al,ah
  1673.            jnz     NotEqual
  1674.            loop    EqualStr1
  1675.  
  1676.            mov     eax,0ffffffffh  ; strings match, return true
  1677.            jmp     @f
  1678. NotEqual:      mov     eax,0
  1679. @@:            pop     ebx
  1680.            mov     [ebx],eax
  1681.            pop     ecx
  1682.            pop     edx
  1683.            pop     esi
  1684.            ret
  1685.  
  1686. LookFor:       pushad
  1687.            lea     ecx,Context           ; look for [EDX]
  1688.            mov     FoundAddr,0
  1689.  
  1690. LookFor1:      mov     esi,[ecx]
  1691.            or      esi,esi
  1692.            jz      LookFor_Done
  1693.            add     esi,VocLinkOffset
  1694.  
  1695. LookFor2:      mov     esi,[esi].Prev         ; go backwards in the chain
  1696.            or      esi,esi
  1697.            jz      LookFor3
  1698.            mov     eax,[esi].NameSize
  1699.            and     eax,eax
  1700.            jz      LookFor3
  1701.  
  1702.            push    esi                    ; save edx
  1703.            lea     esi,[esi].NameSize
  1704.  
  1705.            mov     eax,edx
  1706.            PushForth
  1707.            mov     eax,esi
  1708.            PushForth
  1709.            call    EqualStr
  1710.            PullForth
  1711.  
  1712.            pop     esi
  1713.            and     eax,eax
  1714.            jz      LookFor2
  1715.            mov     FoundAddr,esi          ; put the address in the output
  1716. LookFor_Done:  popad
  1717.            ret
  1718.  
  1719. LookFor3:      add     ecx,4
  1720.            jmp     LookFor1
  1721.  
  1722. ToUpper:       PullForth               ; (c-addr -- )
  1723.            pushad                  ; Converts to upper in place
  1724.            cld
  1725.            mov     esi,eax
  1726.            lodsd
  1727.            mov     ecx,eax
  1728.            or      ecx,ecx
  1729.            jz      ToUpper9
  1730.            lea     ebx,uppercaseTable
  1731.            mov     edi,esi
  1732.  
  1733. @@:            lodsb
  1734.            xlat
  1735.            stosb
  1736.            loop    @b
  1737. ToUpper9:      popad
  1738.            ret
  1739.  
  1740. DoesVariable:  pop     eax
  1741.            PUSHFORTH
  1742.            ret
  1743.  
  1744.            CodeDef 'NUMBER?'        ; ( addr --
  1745.                     ;      value TRUE  (ok value)
  1746.                     ;      addr  FALSE ( bad value )
  1747. _NumberQ:      PullForth
  1748.            pushad                   ; save ALL registers
  1749.            xor      edx,edx
  1750.            mov      Value,edx
  1751.            mov      DPL,edx
  1752.            inc      edx
  1753.            mov      Negative,edx    ; NOT negative
  1754.            lea      ebx,ValueTable
  1755.            xor      edi,edi         ; edi will hold result
  1756.            mov      esi,eax
  1757.            lodsd
  1758.            mov      ecx,eax         ; ecx is number of bytes left
  1759.            or       ecx,ecx
  1760.            jz       _NumberQ9
  1761. _NumberQ1:     xor      eax,eax
  1762.            lodsb
  1763.            xlat
  1764.            cmp      al,0ffh         ; test for bogus number
  1765.            jz       _NumberQ9
  1766.            cmp      al,0feh         ; test for , and .
  1767.            jnz      @f
  1768.            mov      DPL,esi
  1769.            jmp      _NumberQ2
  1770.  
  1771. @@:            cmp      al,0fdh         ; test for -
  1772.            jnz      @f
  1773.            cmp      edi,0
  1774.            jnz      _NumberQ9       ;  '-' in the middle of a number!
  1775.            mov      Negative,-1
  1776.            jmp      _NumberQ2
  1777.  
  1778. @@:            cmp      eax,Number_Base ; test for TOO BIG digit
  1779.            jae      _NumberQ9
  1780.            xchg     eax,edi      ; swap value with eax
  1781.            mul      Number_Base  ; multiply old value by Number Base
  1782.            add      edi,eax      ; add to new in EDI
  1783. _NumberQ2:     loop     _NumberQ1    ; result in EDI, loop until out of chars
  1784.  
  1785.            mov      Value,edi
  1786.            cmp      DPL,0
  1787.            jz       _NumberQOk
  1788.            sub      esi,DPL
  1789.            mov      DPL,esi      ; store the # of digits since in DPL!
  1790.  
  1791. _NumberQOk:    popad
  1792.            mov      eax,Value
  1793.            mul      Negative     ; Multiply by 1 or -1!
  1794.            PushForth
  1795.            mov      eax,-1
  1796.            PushForth
  1797.            ret
  1798.  
  1799. _NumberQ9:     popad                 ; Not a number
  1800.            PushForth             ;  Restore the Address
  1801.            xor      eax,eax
  1802.            PushForth             ; and then a FALSE
  1803.            ret
  1804.  
  1805.            CodeDef '<S">'           ; Puts Address and Count on stack
  1806. Inline_String: pop     ecx              ; (Counted string stored in-line)
  1807.            mov     eax,ecx
  1808.            add     eax,4            ; Push the Address
  1809.            PushForth
  1810.            mov     eax,[ecx]
  1811.            PushForth                ; Push the count
  1812.            add     eax,ecx          ; Add Count+8 to Return address
  1813.            add     eax,8
  1814.            jmp     eax
  1815.  
  1816.            CodeDef '0"',3
  1817.            Call    S_Quote
  1818.            lea     eax,DROP
  1819.            PushForth
  1820.            call    Do_CompileCall
  1821.            ret
  1822.  
  1823.            CodeDef 'SYScall'        ; ( addr --- APIreturnCode )
  1824.            PullForth
  1825.            push    ebx
  1826.            push    ecx
  1827.            push    edx
  1828.            push    esi
  1829.            push    edi
  1830.            push    ebp
  1831.            mov     ebp,esp
  1832.            mov     esp,ebx
  1833.            Call    EAX
  1834.            mov     esp,ebp
  1835.            pop     ebp
  1836.            pop     edi
  1837.            pop     esi
  1838.            pop     edx
  1839.            pop     ecx
  1840.            pop     ebx
  1841.            PushForth
  1842.            ret
  1843.  
  1844.  
  1845.  
  1846.  
  1847.  
  1848.  
  1849.  
  1850.  
  1851.  
  1852.  
  1853.  
  1854.  
  1855. AutoLoad:      pushad                    ; put C:\FLAT32\FORTH.INI into fOpenName
  1856.            mov     esi,Environment   ; on my machine
  1857.            cld
  1858. @@:            lodsb
  1859.            cmp     al,0
  1860.            jnz     @b
  1861.            lodsb
  1862.            cmp     al,0
  1863.            jnz     @b         ; look for a double 0
  1864.  
  1865.            mov     FooBar,ESI
  1866.  
  1867.            lea     edi,FOpenName     ; copy the path, up to the .
  1868. @@:            lodsb
  1869.            stosb
  1870.            cmp     al,'.'
  1871.            jnz     @b
  1872.  
  1873.            mov     al,'I'
  1874.            stosb
  1875.            mov     al,'N'
  1876.            stosb
  1877.            mov     al,'I'
  1878.            stosb
  1879.            xor     eax,eax
  1880.            stosd
  1881.            popad
  1882.  
  1883. ;               CodeDef 'AUTOLOAD'
  1884. ;AutoLoad:
  1885.            call    FOpen
  1886. @@:            PULLFORTH
  1887.            push    eax        ; push handle
  1888.            push    ebx        ; push stack
  1889.            cmp     eax,0
  1890.            jle     Abort
  1891.            PushForth
  1892.            mov     eax,FileBufferSize
  1893.            PushForth
  1894.            call    FRead
  1895.            PullForth
  1896.            or      eax,eax
  1897.            jz      @f
  1898.            mov     InputCount,eax
  1899.            lea     eax,FileBuffer
  1900.            mov     InputBuffer,eax
  1901.            xor     eax,eax
  1902.            mov     InputOffset,eax
  1903.            call    Interpret
  1904.  
  1905. @@:            pop     eax
  1906.            cmp     eax,ebx     ; check if stack changed
  1907.            jne     StackProblem
  1908.            pop     eax
  1909.            PUSHFORTH
  1910.            call    FClose
  1911.            ret
  1912.  
  1913. StackProblem:  lea     edx,StackLoadMsg
  1914.            call    WriteStr
  1915.            jmp     Abort
  1916.  
  1917.  
  1918.  
  1919.  
  1920.  
  1921.  
  1922.  
  1923.  
  1924.  
  1925.  
  1926. MAIN:          mov     SavedESP,ESP
  1927.            mov     ebp,esp
  1928.            mov     EAX,[EBP+12]
  1929.            mov     Environment,EAX
  1930.            mov     EAX,[EBP+16]
  1931.            mov     CommandLine,EAX
  1932.            pushd   012h            ; Write Un-committed
  1933.            pushd   Reserve_Size
  1934.            pushd   offset CodeSpace
  1935.            call    Dos32AllocMem
  1936.            and     eax,eax
  1937.            jnz     Bye
  1938.            mov     esp,SavedESP
  1939.  
  1940.            call    ErrorHandler
  1941.  
  1942.                lea     eax,UserArea           ; Set up USER variables
  1943.                mov     UserVPtr,eax           ; Ptr to free USER var area
  1944.                mov     UserDefaultPtr,UREG    ; Default is itself
  1945.  
  1946.            lea     edx,CopyRightMsg
  1947.            call    WriteStr
  1948.  
  1949.            lea     edx,WelcomeMsg
  1950.            call    WriteStr
  1951.  
  1952.            lea     edx,VersionMsg
  1953.            call    WriteStr
  1954.  
  1955.            lea     edx,GreetMsg
  1956.            call    WriteStr
  1957.  
  1958.            Call    AutoLoad
  1959.            jmp     quit
  1960.  
  1961. VecAbort:      mov     esp,SavedESP
  1962.            call    ErrorHandler
  1963.            jmp     Quit
  1964.  
  1965. ErrorHandler:  mov     UREG,offset U_UserVPtr
  1966.                xor     eax,eax
  1967.                mov     CompileMode,eax
  1968.                mov     SysTo,eax
  1969.                mov     ebx,StackBase
  1970.                mov     EDI,CodeSpace        ; CS:EDI = compile pointer
  1971.                cld                          ; count UP
  1972.                call    ForthVoc
  1973.                ret
  1974.  
  1975. IOerror:       mov     edx,offset IOerrorMsg
  1976.            call    WriteStr
  1977.            mov     edx,offset StrBuffer
  1978.            call    Int_Str
  1979.            call    WriteStr
  1980.            call    DoCr
  1981.            jmp     Abort
  1982.  
  1983.            CodeDef 'DumpRegisters'
  1984. DumpRegisters:
  1985.                pushad
  1986.            push    Number_Base
  1987.            mov     Number_Base,10h
  1988.            pushad
  1989.            lea     edx,RegisterMsg
  1990.            call    WriteStr
  1991.            popad
  1992.  
  1993.            pushad
  1994.            mov     ecx,8
  1995. @@:            lea     edx,Numbuffer
  1996.            mov     ebx,8
  1997.            pop     eax
  1998.            call    Int_StrLen
  1999.            call    WriteStr
  2000.            lea     edx,SpStr
  2001.            call    WriteStr
  2002.            loop    @b
  2003.            call    DoCr
  2004.            pop     Number_Base
  2005.            popad
  2006.            ret
  2007.  
  2008. WriteEAX:
  2009.            pushad
  2010.            lea     edx,NumBuffer
  2011.            call    Int_Str
  2012.            call    WriteStr
  2013.            call    DoCr
  2014.            popad
  2015.            ret
  2016.  
  2017.  
  2018. WriteStr:                           ; writes string at [EDX]
  2019.            pushad
  2020.            xor     eax,eax      ; used as "actual count" storage
  2021.            push    eax
  2022.            mov     eax,esp      ; push the address of the previous push
  2023.            push    eax
  2024.            mov     eax,[edx]    ; push the string length
  2025.  
  2026.            add     OutPos,eax   ; update output position
  2027.  
  2028.            push    eax
  2029.            add     edx,4        ; push the string address
  2030.            push    edx
  2031.            pushd   stdout       ; push the handle to write to
  2032.            call    Dos32Write   ; do the write.
  2033.            add     esp,20       ; set the stack back to semi-normal
  2034.            popad
  2035.            ret
  2036.  
  2037.  
  2038. Int_Str:       pushad               ; No length required...
  2039.            mov     ebx,0
  2040.            jmp     Int_Str0
  2041.  
  2042. Int_StrLen:    pushad
  2043. Int_Str0:                           ; eax-value to print
  2044.                     ; ebx-number of digits..
  2045.                     ; edx-address of buffer to put it in.....
  2046.            pushd   0            ;
  2047.            mov     edi,ebx      ; edi now has count
  2048.            mov     ebx,edx      ; buffer address now in ebx
  2049.            mov     ecx,number_base
  2050.            lea     esi,table
  2051. Int_Str1:
  2052.            mov     edx,0
  2053.            div     ecx
  2054.            mov     edx,[edx+esi]
  2055.            push    edx
  2056.            dec     edi          ; bump counter
  2057.            and     eax,eax
  2058.            jnz     Int_Str1
  2059.            mov     edx,ebx      ; ebx --> count
  2060.            add     edx,4        ; edx --> string data
  2061.            mov     ecx,0        ; ecx = counter
  2062. Int_Str1a:
  2063.            or      edi,edi
  2064.            jle     Int_Str2
  2065.            xor     eax,eax
  2066.            mov     al,Number_Fill
  2067.            push    eax
  2068.            dec     edi
  2069.            jmp     Int_Str1a
  2070. Int_Str2:
  2071.            pop     eax
  2072.            or      al,al
  2073.            jz      Int_Str3
  2074.            mov     [edx],al
  2075.            inc     edx
  2076.            inc     ecx
  2077.            jmp     Int_Str2
  2078. Int_Str3:
  2079.            mov     [ebx],ecx
  2080.            popad
  2081.            ret
  2082.  
  2083. Do_Breakpoint: push    edx
  2084.            lea     edx,BreakMsg
  2085.            call    WriteStr
  2086.            pop     edx
  2087.            ret
  2088.  
  2089. ;
  2090. ; Preliminary routines to build a foundation word list from
  2091. ;
  2092.  
  2093.            CodeDef '?STACK'
  2094. StackCheck:    mov     eax,StackBase
  2095.            cmp     ebx,eax
  2096.            ja      StackUnderflow
  2097.            sub     eax,STACK_SIZE*4
  2098.            cmp     ebx,eax
  2099.            jbe     StackOverflow
  2100.            ret
  2101.  
  2102. StackOverFlow: lea     edx,StackOverMsg
  2103.            call    WriteStr
  2104.            jmp     Abort           ; RESET everything
  2105.  
  2106. StackUnderFlow:
  2107.            lea     edx,StackUnderMsg
  2108.            call    WriteStr
  2109.            jmp     Abort           ; RESET everything
  2110.  
  2111. DivByZero:     call    DumpRegisters
  2112.                lea     EDX,DivByZeroMsg
  2113.            call    WriteStr
  2114.            xor     eax,eax
  2115.            mov     [ebx],eax
  2116.            ret
  2117.  
  2118.            CodeDef 'COMPILE,'
  2119. Do_CompileCall:                         ; Compiles a call to address given
  2120.            mov     al,0E8h
  2121.            stosb
  2122.            PULLFORTH
  2123.  
  2124.            sub     eax,EDI          ; subtract current EIP
  2125.            sub     eax,4            ; subtract 4 for upcoming offset
  2126.            stosd
  2127.            ret
  2128.  
  2129. WriteLineNum:  mov     eax,LineNumber
  2130.            or      eax,eax
  2131.            jz      WriteLineNum9
  2132.            lea     edx,LineNumMsg
  2133.            call    WriteStr
  2134.            mov     eax,10
  2135.            mov     number_base,eax
  2136.            mov     eax,LineNumber
  2137.            call    WriteEAX
  2138.            call    DoCr
  2139.            xor     eax,eax
  2140.            mov     LineNumber,eax
  2141. WriteLineNum9: ret
  2142.  
  2143.            CodeDef 'WORDS'
  2144. Do_Words:      pushad
  2145.                xor     eax,eax               ; Mod 11/14/93 MAW
  2146.                mov     OutLine,eax
  2147.  
  2148.            mov     ecx,offset Context
  2149.  
  2150. Do_Words1:     mov     edx,[ecx]
  2151.            or      edx,edx
  2152.            jz      Do_Words_Done         ; if last CURRENT vocabulary
  2153.            add     edx,VocLinkOffset
  2154. Do_Words2:     mov     edx,[edx].Prev        ; go backwards in the chain
  2155.            or      edx,edx
  2156.            jz      Do_Words3
  2157.            mov     eax,[edx].NameSize
  2158.            or      eax,eax
  2159.            jz      Do_Words3
  2160.  
  2161.            mov     eax,[edx].Flags
  2162.            test    eax,HIDDEN
  2163.            jnz     Do_Words2             ; Skip if marked HIDDEN
  2164.            push    edx
  2165.            lea     edx,[edx].NameSize
  2166.            call    WriteStr
  2167.            lea     edx,SpStr
  2168.            call    WriteStr
  2169.            call    WriteStr
  2170. ;               call    QueryCR
  2171.            call    QueryMore             ; Modified 11/14/93 MAW
  2172.            pop     edx
  2173.            jmp     Do_Words2
  2174.  
  2175. Do_Words3:     add     ecx,4                 ; Finished 1 vocabulary
  2176.            call    DoCr
  2177.            call    DoCr
  2178.            jmp     Do_Words1
  2179.  
  2180. Do_Words_Done: popad
  2181.            ret
  2182.  
  2183.            CodeDef '?CR'
  2184. QueryCr:       mov     edx,OutPos
  2185.            add     edx,16
  2186.            cmp     edx,CharPerLine
  2187.            jg      DoCr
  2188.            ret
  2189.  
  2190.                CodeDef '?CR-MORE'
  2191. QueryMore:     Call    QueryCR
  2192.                mov     edx,OutLine
  2193.                cmp     edx,MoreLength
  2194.                jng     @f
  2195.                mov     edx,MoreVector
  2196.                call    edx
  2197. @@:            ret
  2198.  
  2199.                CodeDef 'PAUSE'
  2200. Pause:         lea     edx,PauseMsg
  2201.                call    WriteStr
  2202.                call    GetKey
  2203.                PullForth               ; drop it
  2204.                lea     edx,PauseClearMsg
  2205.                call    WriteStr
  2206.                xor     eax,eax
  2207.                mov     OutLine,eax
  2208.                mov     OutPos,eax
  2209.                ret
  2210.  
  2211.            CodeDef 'U*'
  2212.            PULLFORTH
  2213.            mul     DWORD PTR [ebx]
  2214.            mov     [ebx],eax
  2215.            ret
  2216.  
  2217.            CodeDef 'U/'
  2218.            PULLFORTH
  2219.            or      eax,eax
  2220.            jz      DivByZero
  2221.            xchg    eax,[ebx]
  2222.            xor     edx,edx
  2223.            div     DWORD PTR[ebx]
  2224.            mov     [ebx],eax
  2225.            ret
  2226.  
  2227.            CodeDef 'W@'
  2228.            mov     eax,[ebx  ]
  2229.            mov     eax,[eax  ]
  2230.            and     eax,00ffffh
  2231.            mov     [ebx  ],eax
  2232.            ret
  2233.  
  2234.            CodeDef 'W!'
  2235.            mov     edx,[ebx  ]      ; value addr .... poke
  2236.            mov     eax,[ebx+4]
  2237.            mov     [edx],ax
  2238.            add     ebx,8            ; pop both values
  2239.            ret
  2240.  
  2241.            CodeDef 'DEBUG'
  2242.            lea     eax,Debug
  2243.            PUSHFORTH
  2244.            ret
  2245.  
  2246.            CodeDef 'ABORT'          ; Vectored ABORT
  2247. Abort:         mov     eax,TickAbort
  2248.            jmp     eax
  2249.  
  2250.            CodeDef "'ABORT"         ; Address of ABORT
  2251.            lea     eax,TickAbort
  2252.            PUSHFORTH
  2253.            ret
  2254.  
  2255.            CodeDef 'EXITCODE'       ; Result code in BYE
  2256.            lea     eax,ExitCode
  2257.            PUSHFORTH
  2258.            ret
  2259.  
  2260.            CodeDef 'HEX'
  2261.            mov     eax,10h
  2262.            mov     Number_Base,eax
  2263.            ret
  2264.  
  2265.            CodeDef '.'             ; Prints number in the current BASE
  2266. Do_Dot:        PullForth
  2267.            cmp     eax,0
  2268.            jge     @f
  2269.            push    eax
  2270.            mov     al,'-'
  2271.            PushForth
  2272.            Call    Do_Emit
  2273.            pop     eax
  2274.            neg     eax
  2275.            jmp     @f
  2276.  
  2277.            CodeDef 'U.'            ; Unsigned PRINT
  2278.            PullForth
  2279.  
  2280. @@:            Push    ESI
  2281.            Push    ECX
  2282.            Push    EDX
  2283.            push    0
  2284.            mov     ecx,Number_Base
  2285.            lea     ESI,Table
  2286. @@:            xor     edx,edx
  2287.            div     ecx             ; AX = Quotient DX = Remainder
  2288.            mov     edx,[edx+esi]
  2289.            push    edx             ; Put the char on the stack
  2290.            or      eax,eax
  2291.            jnz     @b
  2292.  
  2293. @@:            pop     eax
  2294.            or      eax,eax
  2295.            jz      @f
  2296.            PushForth
  2297.            Call    Do_emit
  2298.            jmp     @b
  2299.  
  2300. @@:            pop     EDX
  2301.            pop     ECX
  2302.            pop     ESI
  2303.            ret
  2304.  
  2305.            CodeDef '.S'            ; Non-Destructive stack print
  2306.            mov     ecx,StackBase
  2307. @@:            sub     ecx,4
  2308.            cmp     ecx,ebx
  2309.            jb      @f
  2310.            mov     eax,[ecx]
  2311.            PushForth
  2312.            call    Do_Dot
  2313.            lea     edx,SpStr
  2314.            call    WriteStr
  2315.            jmp     @b
  2316.  
  2317. @@:            call    DoCr
  2318.            ret
  2319.  
  2320.            CodeDef 'SP0'
  2321.            mov     eax,StackBase  ; Base of stack
  2322.            PUSHFORTH
  2323.            ret
  2324.  
  2325.            CodeDef 'SP!'           ; Resets user stack pointer
  2326.            mov     ebx,[ebx]
  2327.            ret
  2328.  
  2329.            CodeDef 'SP@'
  2330.            mov     eax,ebx         ; Forth Stack pointer in EAX
  2331.            PUSHFORTH
  2332.            ret
  2333.  
  2334.            CodeDef 'RP0'           ; Get initial return pointer
  2335.            mov     eax,SavedESP
  2336.            PushForth
  2337.            ret
  2338.  
  2339.            CodeDef 'RP@'           ; Get the current return pointer
  2340.            mov     eax,ESP
  2341.            add     eax,4
  2342.            PushForth
  2343.            ret
  2344.  
  2345.            CodeDef 'RP!'           ; Get our return address....
  2346.            pop     edx
  2347.            PullForth
  2348.            mov     esp,eax
  2349.            push    edx
  2350.            ret
  2351.  
  2352.            CodeDef 'CELL'
  2353.            mov     eax,4           ; Word Size in bytes
  2354.            PUSHFORTH
  2355.            ret
  2356.  
  2357.            CodeDef 'COMPILE',CompileOnly
  2358.                        ; a REALLY SNEAKY forth word
  2359.            pop     eax             ; get return address
  2360.            mov     edx,eax
  2361.            add     eax,5           ; Modify return address, to skip
  2362.            push    eax             ; the next call instruction
  2363.            inc     edx             ; [edx] is call offset
  2364.            add     eax,[edx]       ; eax now has absolute address of call
  2365.  
  2366.            mov     edx,eax
  2367.            mov     al,0E8h         ; put the CALL instruction
  2368.            stosb
  2369.            mov     eax,edx
  2370.  
  2371.            sub     eax,EDI         ; subtract current EIP
  2372.            sub     eax,4           ; subtract 4 for upcoming offset
  2373.            stosd
  2374.            ret                     ; return with the address changed
  2375.  
  2376. ; Some useful words let you temporarily store things on the return stack
  2377. ; Always use >R and R> in pairs
  2378.  
  2379. ;
  2380. ;  CREATE       makes a 0 byte variable
  2381. ;  ALLOT        adds N bytes to the length of the last word created
  2382. ;  ,            takes N, and adds in into the last word compiled
  2383. ;  C,           adds C to the last word compiled
  2384. ;  VARIABLE     makes a 4 byte variable
  2385. ;  DoesVariable Puts the Return address on the stack
  2386. ;  DoesConstant Puts the CONTENTS of the Return address on the stack
  2387. ;
  2388.  
  2389.  
  2390.  
  2391. ;
  2392. ; Conditional Branching Logic
  2393. ;
  2394. ; IF   - Marks code to be executed ONLY on a TRUE
  2395. ; ELSE - Marks code to be executed ONLY of false
  2396. ; THEN - Marks the end of the conditional
  2397. ;
  2398.            CodeDef 'IF',3           ; ONLY in compile mode
  2399.            Call    CompileCheck
  2400.            cld
  2401.            COMPILES 08Bh,003h,083h,0C3h,004h
  2402.            COMPILES 023h,0C0h,00fh,084h
  2403.            xor     eax,eax
  2404.            stosd                   ; set to 0, for safety
  2405.            mov     eax,edi         ; calc offset of DWORD
  2406.            sub     eax,4
  2407.            PUSHFORTH
  2408.            ret
  2409.  
  2410. ; Code generated....
  2411. ; 8B 03            mov      eax,[ebx]
  2412. ; 83 C3 04         add      ebx,4
  2413. ; 23 C0            and      eax,eax
  2414. ; 0F 84 00000000   jz       Next Instruction + Offset....
  2415. ;
  2416.  
  2417.            CodeDef  'THEN',3       ; ONLY in compile mode
  2418.            Call     CompileCheck
  2419.            push     edi
  2420.            PULLFORTH
  2421.            xchg     EDI,EAX        ; Fixup in EDI, current in EAX
  2422.            sub      eax,edi        ; determine offset of this instruction
  2423.            sub      eax,4          ;   from the patches NEXT instruction
  2424.            stosd                   ; Do the patch
  2425.            pop      edi
  2426.            ret
  2427.  
  2428. ; for an ELSE
  2429. ; 1256  E9 00000000      jmp      Next Instruction + Offset....
  2430.  
  2431.            CodeDef  'ELSE',3       ; ONLY in compile mode
  2432.            Call    CompileCheck
  2433.            mov      eax,0E9h
  2434.            stosb                   ; Jump relative 32
  2435.            xor      eax,eax
  2436.            stosd
  2437.            mov      eax,[ebx]      ; get address from IF  (ebx goes back up later)
  2438.            push     edi
  2439.            xchg     edi,eax
  2440.            sub      eax,edi
  2441.            sub      eax,4
  2442.            stosd                   ; Patch IF address
  2443.            pop      edi
  2444.            mov      eax,edi
  2445.            sub      eax,4
  2446.            mov      [ebx],eax      ; replace address with ELSE patch
  2447.            ret
  2448. ;
  2449. ; DO ... LOOP logic
  2450. ;
  2451. ;
  2452. ; DO - Takes 2 values from Forth Stack, puts them on the return stack
  2453. ;      COMPILE: Puts LABEL on stack
  2454. ;
  2455. ; LOOP - Increments loop counter, tests for end of loop, if ok, jums to LABEL
  2456. ;
  2457.  
  2458.            CodeDef 'DO',3          ; COMPILED ONLY, IMMEDIATE
  2459.  
  2460.            Call    CompileCheck
  2461.          COMPILES  08Bh,043h,004h  ; mov   eax,[ebx+4]
  2462.          COMPILES  050h            ; push  eax
  2463.          COMPILES  08Bh,003h       ; mov   eax,[ebx]
  2464.          COMPILES  050h            ; push  eax
  2465.          COMPILES  083h,0C3h,008h  ; add   ebx,8
  2466.  
  2467.            mov     eax,EDI         ; LABEL1:
  2468.            PUSHFORTH
  2469.            ret
  2470.  
  2471.  
  2472.            CodeDef 'LOOP',3             ; CompileOnly, Immediate
  2473.            Call    CompileCheck
  2474.  
  2475.          COMPILES 08bh,004h,024h        ; mov  eax,[esp]
  2476.          COMPILES 040h                  ; inc  eax
  2477.          COMPILES 089h,004h,024h        ; mov  [esp],eax
  2478.          COMPILES 03bh,044h,024h,004h   ; cmp  eax,[esp+4]
  2479.          COMPILES 00fh,08ch             ; jl   RELATIVE32
  2480.            PULLFORTH
  2481.            sub     eax,EDI
  2482.            sub     eax,4                ; calculate from next instruction
  2483.            STOSD
  2484.          COMPILES 083h,0c4h,008h        ; add  esp,8
  2485.            ret
  2486.  
  2487.  
  2488.  
  2489.            CodeDef '<+LOOP>',HIDDEN  ; Smart +LOOP can count down or up
  2490. PlusLoop1:     pop     edx
  2491.            PULLFORTH
  2492.            add     [esp],eax
  2493.            mov     ecx,[esp]
  2494.            or      eax,eax
  2495.            jge     PlusLoop2
  2496.            cmp     4 [esp],ecx
  2497.            jmp     PlusLoop3
  2498. PlusLoop2:     cmp     ecx,4 [esp]
  2499. PlusLoop3:     jge     PlusLoop9
  2500.            add     edx,[edx]
  2501.            add     edx,4
  2502.            jmp     edx         ; loop back
  2503. PlusLoop9:     add     edx,4       ; skip loop-back offset
  2504.            add     esp,8       ; drop loop variables
  2505.            jmp     edx
  2506.  
  2507.            CodeDef '+LOOP',3            ; CompileOnly, Immediate
  2508.            Call    CompileCheck
  2509.            lea     eax,PlusLoop1
  2510.            PUSHFORTH
  2511.            call    Do_CompileCall
  2512.            PULLFORTH
  2513.            sub     eax,EDI
  2514.            sub     eax,4                ; calculate from next instruction
  2515.            STOSD
  2516.            ret
  2517.  
  2518.  
  2519. ; A word which goes along with these will copy the value pushed onto
  2520. ;  the return stack with R> onto the parameter stack.
  2521.  
  2522.            CodeDef 'K'         ; 1 loop up
  2523.            mov     eax,[esp+20] ; return, index, limit, index, limit, index
  2524.            PushForth
  2525.            ret
  2526.  
  2527.            CodeDef 'LEAVE'     ; leave a DO...LOOP
  2528.            mov     eax,[esp+8]
  2529.            mov     [esp+4],eax
  2530.            ret
  2531.  
  2532.            CodeDef 'UNLOOP'    ; remove loop variables from stack
  2533.            mov     eax,[esp]
  2534.            add     esp,8
  2535.            mov     [esp],eax
  2536.            ret
  2537.  
  2538. ;
  2539. ; FOR ... NEXT logic
  2540. ;
  2541. ;
  2542. ; FOR - Takes 2 values from Forth Stack, puts them on the return stack
  2543. ;      MARKER - Take values from stack, if past bound PATCHUP, skip body
  2544. ;
  2545. ; NEXT- Does Patchup, Compiles Jump to MARKER
  2546. ;
  2547. ; DESIRED RESULT:
  2548. ;
  2549. ; 1302  8B 43 04                               mov     eax,[ebx+4]     ; MOVE values to return stack
  2550. ; 1305  50                                     push    eax
  2551. ; 1306  8B 03                                  mov     eax,[ebx]
  2552. ; 1308  50                                     push    eax
  2553. ; 1309  83 C3 08                               add     ebx,8           ; bump counter appropriately
  2554. ; 130C  58                      LABEL1:        pop     eax
  2555. ; 130D  5A                                     pop     edx
  2556. ; 130E  3B C2                                  cmp     eax,edx
  2557. ; 1310  73 11                                  jae     LABEL2
  2558. ; 1312  52                                     push    edx
  2559. ; 1313  50                                     push    eax
  2560. ;
  2561. ; 1314  BA 000000B0 R                          lea     edx,GreetMsg
  2562. ; 1319  E8 FFFFEF91                            call    WriteStr
  2563. ;
  2564. ; 131E  58                                     pop     eax
  2565. ; 131F  40                                     inc     eax
  2566. ; 1320  50                                     push    eax
  2567. ; 1321  EB E9                                  jmp     LABEL1
  2568. ;
  2569. ; 1323                          LABEL2:
  2570. ; 1323  C3                                     ret
  2571.            CodeDef 'FOR',3         ; COMPILED ONLY, IMMEDIATE
  2572.            Call    CompileCheck
  2573.  
  2574.            COMPILES 08Bh,043h,004h ; mov   eax,[ebx+4]
  2575.            COMPILES 050h           ; push  eax
  2576.            COMPILES 08Bh,003h      ; mov   eax,[ebx]
  2577.            COMPILES 050h           ; push  eax
  2578.            COMPILES 083h,0C3h,008h ; add   eax,8
  2579.  
  2580.            mov     eax,EDI         ; LABEL1: Jump back point
  2581.            PUSHFORTH
  2582.  
  2583.            COMPILES 058h           ; pop   eax
  2584.            COMPILES 05Ah           ; pop   edx
  2585.            COMPILES 03Bh,0C2h      ; cmp   eax,edx
  2586.            COMPILES 00fh,083h      ; jea   relative 32
  2587.  
  2588.            mov     eax,EDI         ;       patch point to LABEL2
  2589.            PUSHFORTH
  2590.            xor     eax,eax
  2591.            stosd
  2592.  
  2593.            COMPILES 052h           ; push  edx
  2594.            COMPILES 050h           ; push  eax
  2595.            ret
  2596.  
  2597.  
  2598. ; 131E  58                                     pop     eax
  2599. ; 131F  40                                     inc     eax
  2600. ; 1320  50                                     push    eax
  2601. ; 1321  EB E9                                  jmp     LABEL1
  2602. ;
  2603. ; 1323                          LABEL2:
  2604.  
  2605.            CodeDef 'NEXT',3        ; Compile ONLY, Immediate
  2606.            Call    CompileCheck
  2607.  
  2608.            mov     al,058h         ; pop   eax
  2609.            stosb
  2610.            mov     al,040h         ; inc   eax
  2611.            stosb
  2612.            mov     al,050h         ; push  eax
  2613.            stosb
  2614.            mov     al,0E9h         ; jmp   Relative 32
  2615.            stosb
  2616.            mov     eax,[ebx+4]     ; EAX = LABEL1
  2617.            sub     eax,edi         ; DELTA = LABEL1 - NEXT INSTRUCTION
  2618.            sub     eax,4
  2619.            stosd                   ; Do the backward jump....
  2620.  
  2621.            mov     eax,edi         ;
  2622.            sub     eax,[ebx]       ; Offset = Current - (Patch+4)
  2623.            sub     eax,4
  2624.            push    edi
  2625.            mov     edi,[ebx]
  2626.            STOSD
  2627.            pop     edi
  2628.            add     ebx,8           ; drop 2 stack entries
  2629.            ret
  2630.  
  2631.            CodeDef '>='            ; i.e. 5 5 >=
  2632.            pullforth               ; eax = stack top 5
  2633.            cmp     eax,[ebx]
  2634.            mov     eax,0
  2635.            jg      @f
  2636.            dec     eax
  2637. @@:            mov     [ebx],eax
  2638.            ret
  2639.  
  2640.            CodeDef '<='
  2641.            pullforth
  2642.            cmp      eax,[ebx]
  2643.            mov      eax,0
  2644.            jl       @f
  2645.            dec      eax
  2646. @@:            mov     [ebx],eax
  2647.            ret
  2648.  
  2649.            CodeDef '<>'            ; True if A <> B
  2650.            pullforth
  2651.            cmp     eax,[ebx]
  2652.            mov     eax,0
  2653.            jz      @f
  2654.            not     eax
  2655. @@:            mov     [ebx],eax
  2656.            ret
  2657.  
  2658.            CodeDef 'NOT'          ; 1s complement
  2659.            not     dword ptr[ebx]
  2660.            ret
  2661.  
  2662.            CodeDef 'U*/MOD'       ; ( a b c -- remainder quotient )
  2663.            mov     eax,[ebx+8]
  2664.            mul     DWORD PTR[ebx+4]
  2665.            cmp     edx,[ebx]
  2666.            jg      DivByZero
  2667.            div     DWORD PTR[ebx]
  2668.            add     ebx,4
  2669.            mov     [ebx],eax      ; Store Quotient
  2670.            mov     [ebx+4],edx    ; Store Remainder
  2671.            ret
  2672.  
  2673.            CodeDef 'FOPEN'      ; ( -- handle )
  2674. Fopen:         mov     eax,0ffffffffh
  2675.            mov     FopenHandle,eax
  2676.            pushad
  2677.            pushd   0            ; PEAOP2 (not used, must be 0 )
  2678.            mov     eax,esp
  2679.            push    eax
  2680.            pushd   020h         ; Readonly, deny write
  2681.            pushd   001h         ; Open, fail if non-existant
  2682.            pushd   000h         ; Normal attributes
  2683.            pushd   0            ; Don't change file size
  2684.            lea     eax,FopenAction
  2685.            push    eax
  2686.            lea     eax,FopenHandle
  2687.            push    eax
  2688.            lea     eax,FopenName
  2689.            push    eax
  2690.            call    Dos32Open
  2691.            add     esp,36       ; Drop all of the stuff from the stack
  2692.            popad
  2693.            mov     eax,FopenHandle
  2694.            PushForth            ; put the handle on the stack
  2695.            ret
  2696.  
  2697.            CodeDef 'CLOSE'     ; ( handle -- )
  2698. FClose:        PullForth
  2699.            pushad
  2700.            push    eax
  2701.            call    Dos32Close
  2702.            add     esp,4
  2703.            popad
  2704.            ret
  2705.  
  2706.            CodeDef 'FREAD'      ; ( handle size -- bytes_read )
  2707. FRead:         PullForth            ; eax is size
  2708.            mov     edx,eax
  2709.            pushad
  2710.            push    ebx          ; point at parameter on stack
  2711.            push    edx          ; number of bytes to read
  2712.            lea     eax,FileBuffer
  2713.            push    eax
  2714.            mov     eax,[ebx]    ; handle
  2715.            push    eax
  2716.            call    Dos32Read
  2717.            add     esp,16
  2718.            popad
  2719.            ret
  2720.  
  2721.            CodeDef 'FBUFFER'
  2722.            lea     eax,FileBuffer
  2723.            pushforth
  2724.            ret
  2725.  
  2726.            CodeDef 'LINE#'
  2727.            lea     eax,LineNumber
  2728.            PUSHFORTH
  2729.            ret
  2730.  
  2731.  
  2732.            CodeDef 'BYE'           ; Exit Forth Environment
  2733. BYE:           pushd   1
  2734.            mov     eax,ExitCode
  2735.            push    eax
  2736.            call    Dos32Exit
  2737.  
  2738.  
  2739.            CodeDef 'INTERPRET'
  2740. Interpret:
  2741.            mov     eax,' '
  2742.            PushForth
  2743.            call    _Word
  2744.            mov     eax,[ebx]       ; address of string
  2745.            mov     eax,[eax]       ; count
  2746.            jz      Interpret8      ; (Null string, bail out)
  2747.  
  2748.            call    _Find           ; 0 = Not found
  2749.            PullForth               ; 1 = Immediate
  2750.            or      eax,eax         ;-1 = Normal
  2751.            jz      InterpretNumber
  2752. ;
  2753. ; We have an address, decide if it should be compiled or called.
  2754. ;
  2755.            test    CompileMode,1
  2756.            jz      @f
  2757. ;
  2758. ; This is the "compile mode" branch of things
  2759. ;
  2760.            cmp     eax,1                   ; is it immediate?
  2761.            jz      @f
  2762.            call    Do_CompileCall          ; No, compile it
  2763.            jmp     Interpret
  2764. ;
  2765. ; This is the interpretive branch
  2766. ;
  2767. @@:            call    _Execute                ; Execute a function
  2768.            jmp     Interpret
  2769.  
  2770. Interpret8:    pullforth
  2771. Interpret9:
  2772.            ret
  2773.  
  2774. ;
  2775. ; Handle a possible number, counted string on stack
  2776. ;
  2777. InterpretNumber:
  2778.            call    _NumberQ
  2779.            pullForth
  2780.            or      eax,eax
  2781.            jz      Interpret_NonNumber
  2782.  
  2783.            test    CompileMode,1
  2784.            jz      @f
  2785.            call    _Literal
  2786. @@:            jmp     Interpret
  2787.  
  2788. Interpret_NonNumber:
  2789.            mov     eax,[ebx]                 ; Peek at stack top
  2790.            mov     eax,[eax]                 ; get string length
  2791.            or      eax,eax                   ; Don't warn if it's 0 chars
  2792.            jz      Interpret8
  2793.  
  2794.            lea     edx,What1Msg
  2795.            call    WriteStr
  2796.  
  2797.            Call    _Count
  2798.            Call    _Type
  2799.            lea     edx,What2Msg
  2800.            call    WriteStr
  2801.            call    WriteLineNum
  2802.            jmp     Abort
  2803.  
  2804.            CodeDef 'PROMPT'
  2805. Prompt:        call    DoCr
  2806.            lea     edx,PromptMsg
  2807.            call    WriteStr
  2808.            ret
  2809.  
  2810.            CodeDef 'DP!'
  2811.            PullForth
  2812.            mov     edi,eax
  2813.            mov     CodeSpace,EDI
  2814.            ret
  2815.  
  2816.            CodeDef '?COMPILE'       ; Only works if we're compiling
  2817. CompileCheck:  test    CompileMode,1
  2818.            jz      @f
  2819.            ret
  2820. @@:            lea     edx,CompileOnlyMsg
  2821.            call    WriteStr
  2822.            call    WriteLineNum
  2823.            jmp     Abort            ; RESET everything
  2824.  
  2825.  
  2826.            CodeDef '[COMPILE]',3    ; Compiles the next word, regardless
  2827.            Call    CompileCheck
  2828.            call    Tick
  2829.            PullForth
  2830.            mov     eax,[eax].CodePointer
  2831.            PushForth
  2832.            call    Do_CompileCall
  2833.            ret
  2834.  
  2835.            CodeDef 'POSTPONE',IMMEDIATE ; Compiles the next word
  2836.            CLD
  2837.            Call    CompileCheck
  2838.            call    Tick
  2839.            lea     edx,PostponeImmediate
  2840.            cmp     eax,1               ;  1 = Immediate
  2841.            jz      @f
  2842.            lea     edx,PostponeNormal  ; -1 = Normal
  2843. @@:            mov     eax,edx
  2844.                PushForth                   ; compile call to postpone routine
  2845.                call    Do_CompileCall      ; eats param
  2846.                PullForth                   ; eats other param
  2847.            stosd
  2848.            mov     CodeSpace,edi
  2849.            ret
  2850.  
  2851.  
  2852. PostponeImmediate:
  2853.            pop     edx
  2854.            mov     eax,[edx]
  2855.            add     edx,4
  2856.            push    edx
  2857.            jmp     eax
  2858.  
  2859. PostPoneNormal:
  2860.            pop     edx
  2861.            mov     eax,[edx]
  2862.            add     edx,4
  2863.            push    edx
  2864.            pushforth
  2865.            call    Do_CompileCall
  2866.            ret
  2867.  
  2868. ;
  2869. ; New version 11/14/93 MAW
  2870. ; old version relied on a fixed header size.
  2871. ;
  2872. DoDoes:        mov     edx,NewWord      ; Address of the latest word...
  2873.            mov     edx,[edx].CodePointer  ; get address of code
  2874.                inc     edx              ; skip CALL opcode
  2875.            Pop     EAX              ; Address to jump to....
  2876.                     ; Note: We never return to it!
  2877.            sub     eax,EDX          ; subtract current EIP
  2878.            sub     eax,4            ; subtract 4 for upcoming offset
  2879.            mov     [edx],eax
  2880.  
  2881.            mov     CodeSpace,EDI
  2882.            ret
  2883.  
  2884.  
  2885.            CodeDef 'DOES>',3        ; Compile Only, Immediate
  2886. Does:          Call    CompileCheck
  2887.            lea     eax,DoDoes
  2888.            PushForth
  2889.            Call    Do_CompileCall   ; Put the call to DoDoes in the
  2890.                     ; def that uses DOES>
  2891.            Compiles 058h            ; pop     eax
  2892.            Compiles 083h,0ebh,004h  ; sub     ebx,4
  2893.            Compiles 089h,003h       ; mov     [ebx],eax
  2894.            ret
  2895.  
  2896.            CodeDef 'LAST'           ; The LAST word defined
  2897.            mov     eax,Current
  2898.            mov     eax,[eax+VocLinkOffset]
  2899.            PushForth
  2900.            ret
  2901.  
  2902.            CodeDef '%TO'
  2903.            lea     eax,SysTo
  2904.            PUSHFORTH
  2905.            ret
  2906.  
  2907.            CodeDef 'TO'
  2908.            mov     eax,1
  2909.            mov     SysTo,eax
  2910.            ret
  2911.  
  2912.            CodeDef '+TO'
  2913.            mov     eax,-1
  2914.            mov     SysTo,eax
  2915.            ret
  2916.  
  2917.            CodeDef '<TODOES>'    ; For TO variables
  2918.            mov     eax,SysTo
  2919.            or      eax,eax
  2920.            jz      Fetch
  2921.            xor     ecx,ecx
  2922.            mov     SysTo,ecx     ; reset TO state
  2923.            or      eax,eax
  2924.            jg      Store
  2925.            ja      PlusStore
  2926.  
  2927.            CodeDef 'DROPS'         ; DROPS n items off the stack
  2928. Drops:         inc     DWORD PTR [ebx]
  2929.            shl     DWORD PTR [ebx],1
  2930.            shl     DWORD PTR [ebx],1
  2931.            add     ebx,[ebx]
  2932.            ret
  2933.  
  2934.            CodeDef 'DPL'  ; variable holding decimal point position
  2935.            lea     eax,DPL
  2936.            PUSHFORTH
  2937.            ret
  2938.  
  2939.            CodeDef 'ROLL'     ; ( n -- ) moves n'th word on stack to top
  2940.            PullForth
  2941.            cmp     eax,1      ; not defined for n <= 1
  2942.            jle     @f
  2943.            push    edi
  2944.            push    esi
  2945.            dec     eax
  2946.            mov     ecx,eax
  2947.            dec     eax
  2948.            shl     eax,1
  2949.            shl     eax,1
  2950.            mov     esi,ebx
  2951.            add     esi,eax    ; start from n'th element
  2952.            mov     edi,ebx
  2953.            add     edi,eax
  2954.            add     edi,4
  2955.            add     eax,ebx
  2956.            mov     eax,[eax+4] ; copy ROLL'd value
  2957.            std                 ; move words up
  2958.            rep movsd           ; move stack up
  2959.            cld
  2960.            mov     [ebx],eax  ; store ROLL'd value
  2961.            pop     esi
  2962.            pop     edi
  2963. @@:            ret
  2964.  
  2965.            CodeDef 'CMOVE>'   ; ( src dest n -- ) moves n bytes up
  2966. CmoveBack:     PullForth
  2967.            cmp     eax,1      ; not defined for n < 1
  2968.            jl      @f
  2969.            push    edi
  2970.            push    esi
  2971.            mov     ecx,eax
  2972.            dec     eax
  2973.            mov     esi,[ebx+4]
  2974.            add     esi,eax    ; start from n'th byte
  2975.            mov     edi,[ebx]
  2976.            add     edi,eax
  2977.            std
  2978.            rep movsb          ; move bytes up
  2979.            cld
  2980.            pop     esi
  2981.            pop     edi
  2982. @@:            add     ebx,8
  2983.            ret
  2984.  
  2985.            CodeDef 'CMOVE'    ; ( src dest n -- ) moves n bytes
  2986. Cmove:         PullForth
  2987.            cmp     eax,1      ; not defined for n < 1
  2988.            jl      @f
  2989.            push    edi
  2990.            push    esi
  2991.            mov     ecx,eax
  2992.            mov     esi,[ebx+4]
  2993.            mov     edi,[ebx]
  2994.            rep movsb
  2995.            pop     esi
  2996.            pop     edi
  2997. @@:            add     ebx,8
  2998.            ret
  2999.  
  3000.            CodeDef  "=STRING"  ; ( addr len "string" -- f )
  3001. EqualString:   push    esi
  3002.            push    edx
  3003.            push    ecx
  3004.            mov     esi,[ebx]   ; esi=string
  3005.            mov     ecx,[ebx+4] ; ecx=len    for LOOP
  3006.            add     ebx,8
  3007.            mov     edx,[ebx]
  3008.            push    ebx         ; Save STACK, we're using EBX
  3009.            lea     ebx,UpperCaseTable
  3010.            cld
  3011.            lodsd               ; Length of string1 in eax
  3012.            cmp     eax,ecx     ; compare string lengths
  3013.            jnz     NotEqual
  3014.            jmp     EqualStr1
  3015.  
  3016.            CodeDef '@+'        ; ( addr -- addr+4 [addr] )
  3017.            mov     edx,[ebx]
  3018.            mov     eax,[edx]
  3019.            add     edx,4
  3020.            mov     [ebx],edx
  3021.            PushForth
  3022.            ret
  3023.  
  3024.            CodeDef 'NIP'       ; ( n1 n2 -- n2 )
  3025.            PullForth
  3026.            mov     [ebx],eax
  3027.            ret
  3028.  
  3029.            CodeDef 'PICK'      ; Copies n'th item to top
  3030.            mov     eax,[ebx]
  3031.            cmp     eax,1      ; not defined for n <= 1
  3032.            jl      @f
  3033.            shl     eax,1
  3034.            shl     eax,1
  3035.            add     eax,ebx
  3036.            mov     eax,[eax]
  3037.            mov     [ebx],eax
  3038. @@:            ret
  3039.  
  3040.            CodeDef '#OUT'       ; Output position
  3041.            lea     eax,DWORD PTR OutPos
  3042.            PushForth
  3043.            ret
  3044.  
  3045.            CodeDef 'WITHIN'     ; ( n1 n2 n3 -- f ) True if n1<=n2<=n3
  3046.            xor     edx,edx
  3047.            mov     eax,[ebx+8]
  3048.            cmp     eax,[ebx]    ; cmp n1,n3
  3049.            jg      @f
  3050.            cmp     eax,[ebx+4]  ; cmp n1,n2
  3051.            jl      @f
  3052.            dec     edx
  3053. @@:            add     ebx,8
  3054.            mov     [ebx],edx
  3055.            ret
  3056.  
  3057.            CodeDef 'CURRENT'    ; Vocabulary where definitions are added
  3058.            lea     eax,WORD PTR Current
  3059.            PushForth
  3060.            ret
  3061.  
  3062.            CodeDef 'CONTEXT'    ; Vocabulary where words are searched for
  3063.            lea     eax,WORD PTR Context
  3064.            PushForth
  3065.            ret
  3066.  
  3067.            CodeDef 'CONTEXTSIZE'  ; Size in words of CONTEXT
  3068.            mov     eax,ContextSize
  3069.            PushForth
  3070.            ret
  3071.  
  3072.            CodeDef 'VOC-LINK'   ; Location of most recent vocabulary
  3073.            lea     eax,WORD PTR Voc_link
  3074.            PushForth
  3075.            ret
  3076.  
  3077.            CodeDef '<VOCABULARY>' ; ( vocabulary -- ) Adds voc to CONTEXT
  3078. DoVocabulary:  push    esi
  3079.            push    edi
  3080.            mov     edi,offset Context  ; list of search vocabularies
  3081.            mov     eax,[ebx]           ; check if vocab already listed
  3082.            mov     ecx,ContextSize-1   ; max # of vocabularies
  3083.            cld
  3084.            repne scasd                 ; Look for the vocabulary
  3085.            or      ecx,ecx
  3086.            jnz     RollVocab           ; If already listed, roll to top
  3087.  
  3088.            mov     edx,[ebx]
  3089.            jmp     ShiftVocab
  3090.  
  3091. ;              mov     edi,offset Context
  3092. ;              xor     eax,eax
  3093. ;              mov     ecx,ContextSize-1
  3094. ;              repne scasd                 ; Look for the first 0
  3095. ;              mov     eax,[ebx]
  3096. ;              mov     [edi-4],eax         ; Vocabulary to add to Context
  3097.  
  3098. RollVocab:     mov     eax,edi
  3099.            cmp     eax,offset Context+4
  3100.            je      DoVocab9            ; If vocab is already first
  3101.            mov     edx,[edi-4]         ; vocab to roll to top
  3102.  
  3103. ShiftVocab:    sub     edi,4
  3104.            mov     esi,edi
  3105.            sub     esi,4
  3106.            neg     ecx
  3107.            add     ecx,ContextSize-2
  3108.            std
  3109.            rep movsd                   ; move vocabs down
  3110.            cld
  3111.            mov     Context,edx         ; store vocabulary at top
  3112.  
  3113. DoVocab9:      pop     edi
  3114.            pop     esi
  3115.            add     ebx,4
  3116.            ret
  3117.  
  3118. SetVocabulary: pop     eax           ; Expects a vocab record after it
  3119.            PUSHFORTH
  3120.            call    DoVocabulary
  3121.            ret
  3122.  
  3123.          CodeDef 'FORTH',IMMEDIATE
  3124. ForthVoc:        lea     eax,ForthLink
  3125.          PUSHFORTH
  3126.          call    DoVocabulary
  3127.          ret
  3128. ; ForthVoc:      call    SetVocabulary
  3129. ; ForthLink      dd      0,LastForthWord,0       ; FORTH vocabulary pointer
  3130.  
  3131.  
  3132.          CodeDef 'SYSTEM',1       ; SYSTEM vocabulary
  3133. SysVoc:          lea     eax,SysLink
  3134.          PUSHFORTH
  3135.          call    DoVocabulary
  3136.          ret
  3137. ; SysVoc:        call    SetVocabulary
  3138. ; SysLink        dd      0,LastHeader,ForthLink  ; SYSTEM vocabulary pointer
  3139.  
  3140.  
  3141.            CodeDef 'FALSE'                 ; Core extension
  3142.            xor     eax,eax
  3143.            PUSHFORTH
  3144.            ret
  3145.  
  3146.            CodeDef 'TRUE'                  ; Core extension
  3147.            xor     eax,eax
  3148.            dec     eax
  3149.            PUSHFORTH
  3150.            ret
  3151.  
  3152. LastForthWord  =       LastHeader
  3153. LastHeader     =       0
  3154.  
  3155.            CodeDef 'MS'
  3156.            PullForth
  3157.            Push    EAX
  3158.            Call    Dos32Sleep
  3159.            Add     ESP,4
  3160.            ret
  3161.  
  3162.            CodeDef 'SYS$BEEP'
  3163.            lea     eax,Dos32Beep
  3164.            PushForth
  3165.            ret
  3166.  
  3167.            CodeDef 'SYS$CALLNPIPE'
  3168.            lea     eax,Dos32CallNPipe
  3169.            PushForth
  3170.            ret
  3171.  
  3172.            CodeDef 'SYS$CLOSE'
  3173.            lea     eax,Dos32Close
  3174.            PushForth
  3175.            ret
  3176.  
  3177.            CodeDef 'SYS$CONNECTNPIPE'
  3178.            lea     eax,Dos32ConnectNPipe
  3179.            PushForth
  3180.            ret
  3181.  
  3182.            CodeDef 'SYS$CREATENPIPE'
  3183.            lea     eax,Dos32CreateNPipe
  3184.            PushForth
  3185.            ret
  3186.  
  3187.            CodeDef 'SYS$CREATETHREAD'
  3188.            lea     eax,Dos32CreateThread
  3189.            PushForth
  3190.            ret
  3191.  
  3192.            CodeDef 'SYS$DEVIOCTL'
  3193.            lea     eax,Dos32DevIOCtl
  3194.            PushForth
  3195.            ret
  3196.  
  3197.            CodeDef 'SYS$DISCONNECTNPIPE'
  3198.            lea     eax,Dos32ExecPgm
  3199.            PushForth
  3200.            ret
  3201.  
  3202.            CodeDef 'SYS$EXECPGM'
  3203.            lea     eax,Dos32ExecPgm
  3204.            PushForth
  3205.            ret
  3206.  
  3207.            CodeDef 'SYS$EXIT'
  3208.            lea     eax,Dos32Exit
  3209.            PushForth
  3210.            ret
  3211.  
  3212.            CodeDef 'SYS$FREEMODULE'
  3213.            lea     eax,Dos32FreeModule
  3214.            PushForth
  3215.            ret
  3216.  
  3217.                CodeDef 'Sys$GetDateTime'
  3218.                lea     eax,Dos32GetDateTime
  3219.                PushForth
  3220.                ret
  3221.  
  3222.                CodeDef 'Sys$GetInfoBlocks'
  3223.                lea     eax,Dos32GetInfoBlocks
  3224.                PushForth
  3225.                ret
  3226.  
  3227.            CodeDef 'SYS$KILLPROCESS'
  3228.            lea     eax,Dos32KillProcess
  3229.            PushForth
  3230.            ret
  3231.  
  3232.            CodeDef 'SYS$KILLTHREAD'
  3233.            lea     eax,Dos32KillThread
  3234.            PushForth
  3235.            ret
  3236.  
  3237.            CodeDef 'SYS$LOADMODULE'
  3238.            lea     eax,Dos32LoadModule
  3239.            PushForth
  3240.            ret
  3241.  
  3242.            CodeDef 'SYS$OPEN'
  3243.            lea     eax,Dos32Open
  3244.            PushForth
  3245.            ret
  3246.  
  3247.            CodeDef 'SYS$PEEKNPIPE'
  3248.            lea     eax,Dos32PeekNPipe
  3249.            PushForth
  3250.            ret
  3251.  
  3252.            CodeDef 'SYS$QUERYMODULEHANDLE'
  3253.            lea     eax,Dos32QueryModuleHandle
  3254.            PushForth
  3255.            ret
  3256.  
  3257.            CodeDef 'SYS$QUERYMODULENAME'
  3258.            lea     eax,Dos32QueryModuleName
  3259.            PushForth
  3260.            ret
  3261.  
  3262.            CodeDef 'SYS$QUERYNPHSTATE'
  3263.            lea     eax,Dos32QueryNPHState
  3264.            PushForth
  3265.            ret
  3266.  
  3267.            CodeDef 'SYS$QUERYNPIPEINFO'
  3268.            lea     eax,Dos32QueryNPipeInfo
  3269.            PushForth
  3270.            ret
  3271.  
  3272.            CodeDef 'SYS$QUERYPROCADDR'
  3273.            lea     eax,Dos32QueryProcAddr
  3274.            PushForth
  3275.            ret
  3276.  
  3277.            CodeDef 'SYS$QUERYPROCTYPE'
  3278.            lea     eax,Dos32QueryProcType
  3279.            PushForth
  3280.            ret
  3281.  
  3282.            CodeDef 'SYS$READ'
  3283.            lea     eax,Dos32Read
  3284.            PushForth
  3285.            ret
  3286.  
  3287.            CodeDef 'SYS$RESUMETHREAD'
  3288.            lea     eax,Dos32ResumeThread
  3289.            PushForth
  3290.            ret
  3291.  
  3292.            CodeDef 'SYS$SEEK'
  3293.            lea     eax,Dos32SetFilePtr
  3294.            PushForth
  3295.            ret
  3296.  
  3297.            CodeDef 'SYS$SETNPHSTATE'
  3298.            lea     eax,Dos32SetNPHState
  3299.            PushForth
  3300.            ret
  3301.  
  3302.            CodeDef 'SYS$SLEEP'
  3303.            lea     eax,Dos32Sleep
  3304.            PushForth
  3305.            ret
  3306.  
  3307.            CodeDef 'SYS$STARTSESSION'
  3308.            lea     eax,Dos32StartSession
  3309.            PushForth
  3310.            ret
  3311.  
  3312.            CodeDef 'SYS$SUSPENDTHREAD'
  3313.            lea     eax,Dos32SuspendThread
  3314.            PushForth
  3315.            ret
  3316.  
  3317.            CodeDef 'SYS$TRANSACTNPIPE'
  3318.            lea     eax,Dos32TransactNPipe
  3319.            PushForth
  3320.            ret
  3321.  
  3322.            CodeDef 'SYS$WAITCHILD'
  3323.            lea     eax,Dos32WaitChild
  3324.            PushForth
  3325.            ret
  3326.  
  3327.            CodeDef 'SYS$WAITNPIPE'
  3328.            lea     eax,Dos32WaitNPipe
  3329.            PushForth
  3330.            ret
  3331.  
  3332.            CodeDef 'SYS$WAITTHREAD'
  3333.            lea     eax,Dos32WaitThread
  3334.            PushForth
  3335.            ret
  3336.  
  3337.            CodeDef 'SYS$WRITE'
  3338.            lea     eax,Dos32Write
  3339.            PushForth
  3340.            ret
  3341.  
  3342.  
  3343.            CodeDef 'SYS$SHUTDOWN'
  3344.            lea     eax,Dos32ShutDown
  3345.            PushForth
  3346.            ret
  3347.  
  3348.            CodeDef 'ENVIRONMENT'
  3349.            mov     EAX,Environment
  3350.            PUSHFORTH
  3351.            ret
  3352.  
  3353.            CodeDef 'COMMANDLINE'
  3354.            mov     EAX,CommandLine
  3355.            PUSHFORTH
  3356.            ret
  3357.  
  3358.                CodeDef 'THREADPROC'    ; Sets up thread then jumps to it
  3359.                pushd   0
  3360.                mov     edx,esp         ; Where base addr is to be stored
  3361.  
  3362.                pushd   012h            ; Write Un-committed
  3363.                pushd   UserAreaSize
  3364.                push    edx
  3365.                call    Dos32AllocMem   ; Allocate USER variable area
  3366.                and     eax,eax
  3367.                jnz     Bye
  3368.                add     esp,12
  3369.  
  3370.                mov     ebx,esp
  3371.                sub     ebx,RSTACK_SIZE ; Set user stack below return stack
  3372.                add     ebx,12          ; Correct for ThreadArg, EIP, USER0
  3373.  
  3374.                mov     edx,[esp+8]     ; get address of thread parameters
  3375.                mov     esi,[edx]       ;   which is stored at ThreadArg
  3376.                mov     esi,[esi]       ; Address of default user area
  3377.  
  3378.                mov     edi,[esp]       ; edi gets new USER area base address
  3379.  
  3380.                mov     UREG,esi
  3381.                mov     ecx,UserVPtr    ; Length of default USER area
  3382.                lea     eax,UserVPtr
  3383.                sub     ecx,eax      ; ecx=size of user area to copy
  3384.                shr     ecx,1        ; divide by 4
  3385.                shr     ecx,1
  3386.                rep     movsd        ; Copy user area to new user area
  3387.  
  3388.                pop     UREG         ; User variable base address
  3389.                mov     edi,CodeSpace
  3390.  
  3391.                mov     StackBase,ebx  ; Update StackBase for this thread
  3392.  
  3393.                mov     edx,[esp+4]  ; Address of ThreadArg
  3394.                mov     edx,[edx]
  3395.                mov     eax,[edx+4]  ; Address of thread code
  3396.                jmp     eax
  3397.                ret
  3398.  
  3399.                CodeDef 'USER0'       ; Start of USER variable area
  3400.                sub     ebx,4
  3401.                mov     [ebx],UREG
  3402.                ret
  3403.  
  3404.                CodeDef 'UDP'         ; USER variable pointer
  3405.                lea     eax,UserVPtr
  3406.                PUSHFORTH
  3407.                ret
  3408.  
  3409.                CodeDef "'USER"       ; Address of default USER area
  3410.                lea     eax,UserDefaultPtr
  3411.                PUSHFORTH
  3412.                ret
  3413.  
  3414.                CodeDef "<USER>"      ; Pushes address of USER variable
  3415. Do_User:       pop     eax
  3416.                mov     eax,[eax]
  3417.                add     eax,UREG
  3418.                PUSHFORTH
  3419.                ret
  3420.  
  3421.                CodeDef 'USER'        ; create USER variable
  3422.                call    Do_Colon
  3423.                mov     eax,UserVPtr
  3424.                add     eax,4         ; Add check to see if past limit
  3425.                mov     UserVPtr,eax
  3426.                sub     eax,4
  3427.                sub     eax,UREG
  3428.                PUSHFORTH
  3429.                lea     eax,Do_User
  3430.                PUSHFORTH
  3431.                call    Do_CompileCall
  3432.                call    Comma
  3433.                xor     eax,eax
  3434.                mov     CompileMode,eax
  3435.                mov     eax,NewWord      ; update the dictionary
  3436.                mov     edx,Current
  3437.                mov     [edx+VocLinkOffset],eax ; update Current vocab ptr
  3438.                ret
  3439.  
  3440.                CodeDef 'VERSION'
  3441.                lea     edx,WelcomeMsg
  3442.            call    WriteStr
  3443.                Call    DoCR
  3444.                ret
  3445.  
  3446.  
  3447. ;
  3448. ;*********** FLOATING POINT WORDS
  3449. ;
  3450.            CodeDef 'FCLEAR'  ; Initializes everything
  3451.            FINIT
  3452.            PUSHD   037fh
  3453.            FLDCW   [ESP]     ; Double Precision, round towards nearest
  3454.            ADD     ESP,4
  3455.            ret
  3456.  
  3457.            CodeDef 'D>F'     ; Convert an Integer to the real stack
  3458.            FILD    Dword Ptr[EBX]
  3459.            add     EBX,4
  3460.            ret
  3461.  
  3462.            CodeDef 'F>D'     ; Truncate to forth stack
  3463.            sub     EBX,4
  3464.  
  3465.            PUSHD   0f7fh     ; Modify control value
  3466.            FLDCW   [ESP]
  3467.            ADD     ESP,4
  3468.  
  3469.            FISTP   DWord Ptr[EBX]
  3470.  
  3471.            PUSHD   037fh     ; Set it back
  3472.            FLDCW   [ESP]
  3473.            ADD     ESP,4
  3474.            ret
  3475.  
  3476.  
  3477.            CodeDef 'F@'
  3478.            PullForth
  3479.            FLD     QWORD PTR [EAX]
  3480.            ret
  3481.  
  3482.            CodeDef 'F!'
  3483.            PullForth
  3484.            FSTP    QWORD PTR [EAX]
  3485.            ret
  3486.  
  3487.            CodeDef 'F+'
  3488.            FADDP   ST(1),ST
  3489.            ret
  3490.  
  3491.            CodeDef 'F-'
  3492.            FSUBP   ST(1),ST
  3493.            ret
  3494.  
  3495.            CodeDef 'F*'
  3496.            FMULP   ST(1),ST
  3497.            ret
  3498.  
  3499.            CodeDef 'F/'
  3500.            FDIV
  3501.            ret
  3502.  
  3503.            CodeDef 'F0<'
  3504.            FTST
  3505.            FSTSW   AX
  3506.            SAHF
  3507.            MOV     EAX,0
  3508.            SBB     EAX,0
  3509.            PushForth
  3510.            ret
  3511.  
  3512.            CodeDef 'F0='
  3513.            FTST
  3514.            FSTSW   AX
  3515.            SAHF
  3516.            MOV     EAX,0
  3517.            JNZ     @F
  3518.            MOV     EAX,-1
  3519. @@:            RET
  3520.  
  3521.            CodeDef 'F<'
  3522.            FCOMPP
  3523.            FSTSW   AX
  3524.            SAHF
  3525.            MOV     EAX,0
  3526.            SBB     EAX,0
  3527.            PushForth
  3528.            ret
  3529.  
  3530.            CodeDef 'FDROP'
  3531.            FFREE   ST         ; free the register
  3532.            FINCSTP            ; bump the stack counter
  3533.            ret
  3534.  
  3535.            CodeDef 'FDUP'
  3536.            FLD     ST
  3537.            ret
  3538.  
  3539.  
  3540.            CodeDef 'FSWAP'
  3541.            FXCH    ST(1)
  3542.            ret
  3543.  
  3544.            CodeDef 'FVARIABLE'
  3545.            call    Create
  3546.            mov     eax,8
  3547.            PUSHFORTH
  3548.            call    Allot
  3549.            ret
  3550.  
  3551.            CodeDef 'FLOOR'
  3552.            PUSHD   0f7fh      ; Modify control value
  3553.            FLDCW   [ESP]
  3554.            ADD     ESP,4
  3555.  
  3556.            FRNDINT
  3557.  
  3558.            PUSHD   037fh      ; Set it back
  3559.            FLDCW   [ESP]
  3560.            ADD     ESP,4
  3561.            RET
  3562.  
  3563.            CodeDef 'FROUND'   ; Round to nearest
  3564.            FRNDINT
  3565.            RET
  3566.  
  3567.            CodeDef 'FDEPTH'   ; Depth of Stack...
  3568.            FSTSW   AX
  3569.            AND     EAX,00003c00h
  3570.            SHR     EAX,11
  3571.            XOR     EAX,7
  3572.            INC     EAX
  3573.            AND     EAX,7
  3574.            PUSHForth
  3575.            Ret
  3576.  
  3577.            CodeDef 'FALIGN'
  3578.            ret
  3579.  
  3580.            CodeDef 'FALIGNED'
  3581.            ret
  3582.  
  3583. DoesFConstant: pop     eax
  3584.            FLD     Qword Ptr[eax]
  3585.            ret
  3586.  
  3587.  
  3588. ;
  3589. ;***** Floating Point EXTENSION words *****
  3590. ;
  3591.            CodeDef 'FABS'
  3592.            FABS
  3593.            ret
  3594.  
  3595.            CodeDef 'FCOS'
  3596.            FCOS
  3597.            ret
  3598.  
  3599.            CodeDef 'FSIN'
  3600.            FSIN
  3601.            ret
  3602.  
  3603.            CodeDef 'FSINCOS'
  3604.            FSINCOS
  3605.            ret
  3606.  
  3607.            CodeDef 'FSQRT'
  3608.            FSQRT
  3609.            ret
  3610.  
  3611. ;
  3612. ; Code FOR F. - What a pig!
  3613. ;
  3614. CvtDigit:      cmp     eax,Number_Base
  3615.            jae     BadDigit
  3616.  
  3617.            cmp     eax,0
  3618.            jb      BadDigit
  3619.  
  3620.            lea     ESI,Table
  3621.            mov     al,[esi+eax]
  3622.            ret
  3623.  
  3624. BadDigit:      mov     eax,'?'
  3625.            ret
  3626.  
  3627.  
  3628.            CodeDef 'F.'
  3629.  
  3630.            PUSHAD
  3631.  
  3632.            XOR     EAX,EAX    ; Push a 0 to the stack
  3633.            Push    EAX
  3634.            MOV     EDI,0      ; EDI is EXPONENT in this app!
  3635.  
  3636.            FTST
  3637.            FSTSW   AX
  3638.            SAHF
  3639.            JAE     @f
  3640.            MOV     EAX,'-'
  3641.            PushForth
  3642.            Call    Do_Emit
  3643.  
  3644. @@:            FABS               ; FStack top >= 0
  3645.            Push    07fffffffh
  3646.            FICOM   Dword Ptr[ESP]
  3647.            ADD     ESP,4      ; Compare to maxint
  3648.            FSTSW   AX
  3649.            SAHF
  3650.            JB      ShowFloat
  3651.  
  3652. @@:            FIDIV   Number_Base
  3653.            INC     EDI
  3654.            FICOM   Number_Base
  3655.            FSTSW   AX
  3656.            SAHF
  3657.            JAE     @b
  3658.  
  3659. ShowFloat:     PUSHD   0f7fh      ; Modify control value
  3660.            FLDCW   [ESP]      ; FLOOR mode
  3661.            ADD     ESP,4
  3662.  
  3663.            PUSH    EAX
  3664.            FLD     ST         ; Dup Stack Top -- X,X
  3665.            FRNDINT            ;                  Trunc(X),X
  3666.            FIST    Dword Ptr[ESP] ;              Trunc(X),X
  3667.            FSUBP   ST(1),ST   ;                  Frac(X)
  3668.            POP     EAX        ; Whole in EAX
  3669.  
  3670.            mov     ecx,Number_Base
  3671.            lea     ESI,Table
  3672. @@:            xor     edx,edx
  3673.            div     ecx             ; AX = Quotient DX = Remainder
  3674.  
  3675.            xchg    edx,eax
  3676.            call    CvtDigit
  3677.            xchg    edx,eax
  3678.  
  3679.            push    edx             ; Put the char on the stack
  3680.            or      eax,eax
  3681.            jnz     @b
  3682.  
  3683. @@:            pop     eax
  3684.            or      eax,eax
  3685.            jz      FPrintFrac
  3686.            PushForth
  3687.            Call    Do_emit
  3688.            jmp     @b
  3689.  
  3690. ;
  3691. ; Print The Fraction in ST
  3692. ;
  3693. FprintFrac:    mov     eax,'.'         ; Put the decimal point
  3694.            PushForth
  3695.            Call    Do_Emit         ; FRAC(X)
  3696.  
  3697. @@:            FIMUL   Number_Base     ; FRAC(X)*10?
  3698.            Push    EAX
  3699.            FIST    Dword Ptr[ESP]
  3700.            Pop     EAX
  3701.            Call    CvtDigit
  3702.            PushForth
  3703.            call    Do_Emit
  3704.  
  3705.            FTST
  3706.            FSTSW   AX
  3707.            SAHF
  3708.            JZ      @f
  3709.            FLD     ST         ; Dup Stack Top -- X,X
  3710.            FRNDINT
  3711.            FSUBP   ST(1),ST
  3712.            JMP     @b
  3713.  
  3714. @@:            FFREE   ST         ; free the register
  3715.            FINCSTP            ; bump the stack counter
  3716.  
  3717.            CMP     EDI,0
  3718.            JZ      FPrintDone
  3719.            MOV     EAX,'E'
  3720.            PushForth
  3721.            Call    Do_Emit
  3722.  
  3723.            MOV     EAX,'+'
  3724.            CMP     EDI,0
  3725.            JA      @F
  3726.            MOV     EAX,'-'
  3727. ;               NEG     EBP
  3728.                NEG     EDI             ; MOD 11/20/93 MAW
  3729. @@:            PushForth
  3730.            Call    Do_Emit
  3731.            MOV     EAX,EDI
  3732.  
  3733.            push    0
  3734.            mov     ecx,Number_Base
  3735.            lea     ESI,Table
  3736. @@:            xor     edx,edx
  3737.            div     ecx             ; AX = Quotient DX = Remainder
  3738.  
  3739.            xchg    edx,eax
  3740.            call    CvtDigit
  3741.            xchg    edx,eax
  3742.  
  3743.            push    edx             ; Put the char on the stack
  3744.            or      eax,eax
  3745.            jnz     @b
  3746.  
  3747. @@:            pop     eax
  3748.            or      eax,eax
  3749.            jz      FPrintDone
  3750.            PushForth
  3751.            Call    Do_emit
  3752.            jmp     @b
  3753.  
  3754. FprintDone:    PUSHD   037fh      ; Set round mode
  3755.            FLDCW   [ESP]
  3756.            ADD     ESP,4
  3757.  
  3758.            POPAD
  3759.            RET
  3760.  
  3761.  
  3762.            CodeDef 'NOP'
  3763.            ret
  3764.  
  3765.            CodeDef 'PI'
  3766.            FLDPI
  3767.            ret
  3768.  
  3769.            CodeDef 'CIN'            ; ( addr -- data )
  3770.            mov     eax,esp          ; save current ss, esp
  3771.            push    ss               ; for return from 16-bit land
  3772.            push    eax
  3773.            mov     eax,esp          ; convert stack so 16-bit can use it
  3774.            ror     eax,16
  3775.            shl     eax,3
  3776.            or      al,7             ; convert to ring-3 tiled segment
  3777.            mov     ss,eax
  3778.  
  3779.            mov     edx,[ebx]
  3780.            xor     eax,eax
  3781.            jmp     far ptr Do_inp16
  3782.  
  3783. Do_inp2        label   far
  3784.            movzx   esp,sp           ; make sure that esp is correct
  3785.            lss     esp,[esp]
  3786.            mov     [ebx],eax
  3787.            ret
  3788.  
  3789.            CodeDef 'COUT'           ; ( data addr -- )
  3790.            mov     eax,esp          ; save current ss, esp
  3791.            push    ss               ; for return from 16-bit land
  3792.            push    eax
  3793.            mov     eax,esp          ; convert stack so 16-bit can use it
  3794.            ror     eax,16
  3795.            shl     eax,3
  3796.            or      al,7             ; convert to ring-3 tiled segment
  3797.            mov     ss,eax
  3798.  
  3799.            PullForth
  3800.            mov     edx,eax
  3801.            PullForth
  3802.            jmp     far ptr Do_out16
  3803.  
  3804. Do_out2        label   far
  3805.            movzx   esp,sp           ; make sure that esp is correct
  3806.            lss     esp,[esp]
  3807.            ret
  3808.  
  3809. MYCODE         SEGMENT PARA USE16 PUBLIC 'CODE'
  3810. Do_Emit16      LABEL   FAR16
  3811.            call    VIOwrtTTY
  3812.            add     sp,4             ; toss the parameters for the DOS16 call
  3813.            jmp     FLAT:Do_Emit2
  3814.  
  3815. Do_GetKey16    LABEL   FAR16
  3816.            call    KbdCharIn
  3817.            jmp     FLAT:Do_GetKey2
  3818.  
  3819. Do_inp16       LABEL   FAR16
  3820.            call    @inp
  3821.            jmp     FLAT:DO_inp2
  3822.  
  3823. Do_Out16       LABEL   FAR16
  3824.            call    @outp
  3825.            jmp     FLAT:DO_out2
  3826.  
  3827. MYCODE         ends
  3828.  
  3829.            .code
  3830.  
  3831.            end     main
  3832.